From 97bb12578f40031331da047aac52d62fd4d1ee63 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sat, 26 Jul 2025 21:30:51 +0200 Subject: [PATCH 01/40] base setup for actions + tests --- analysis/src/Cmt.ml | 14 ++++ compiler/bsc/rescript_compiler_main.ml | 2 + compiler/ml/cmt_format.ml | 33 ++++++++- compiler/ml/cmt_format.mli | 3 + 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 | 53 ++++++++++++++ 26 files changed, 331 insertions(+), 7 deletions(-) create mode 100644 compiler/ml/cmt_utils.ml 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/analysis/src/Cmt.ml b/analysis/src/Cmt.ml index a433d12908..ac1d5ae595 100644 --- a/analysis/src/Cmt.ml +++ b/analysis/src/Cmt.ml @@ -51,3 +51,17 @@ let fullsFromModule ~package ~moduleName = let loadFullCmtFromPath ~path = let uri = Uri.fromPath path in fullFromUri ~uri + +let loadCmtInfosFromPath ~path = + let uri = Uri.fromPath path in + match Packages.getPackage ~uri with + | None -> None + | Some package -> ( + let moduleName = + BuildSystem.namespacedName package.namespace (FindFiles.getName path) + in + match Hashtbl.find_opt package.pathsForModule moduleName with + | Some paths -> + let cmt = getCmtPath ~uri paths in + Shared.tryReadCmt cmt + | None -> None) diff --git a/compiler/bsc/rescript_compiler_main.ml b/compiler/bsc/rescript_compiler_main.ml index e91361d1ac..52493a0047 100644 --- a/compiler/bsc/rescript_compiler_main.ml +++ b/compiler/bsc/rescript_compiler_main.ml @@ -462,4 +462,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 907f2e7122..2d24a1cbb1 100644 --- a/compiler/ml/cmt_format.ml +++ b/compiler/ml/cmt_format.ml @@ -63,6 +63,7 @@ type cmt_infos = { cmt_imports : (string * Digest.t option) list; cmt_interface_digest : Digest.t option; cmt_use_summaries : bool; + cmt_possible_actions : Cmt_utils.cmt_action list; } type error = @@ -154,15 +155,22 @@ let read_cmi filename = let saved_types = ref [] let value_deps = ref [] +let possible_actions = ref [] let clear () = saved_types := []; - value_deps := [] + value_deps := []; + possible_actions := [] let add_saved_type b = saved_types := b :: !saved_types let get_saved_types () = !saved_types let set_saved_types l = saved_types := l +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 value_deps := (vd1, vd2) :: !value_deps @@ -172,8 +180,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 = @@ -197,6 +227,7 @@ let save_cmt filename modname binary_annots sourcefile initial_env cmi = cmt_imports = List.sort compare (Env.imports ()); cmt_interface_digest = this_crc; cmt_use_summaries = need_to_clear_env; + 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 1a84aa68d0..64dc7ce3ac 100644 --- a/compiler/ml/cmt_format.mli +++ b/compiler/ml/cmt_format.mli @@ -63,6 +63,7 @@ type cmt_infos = { cmt_imports: (string * Digest.t option) list; cmt_interface_digest: Digest.t option; cmt_use_summaries: bool; + cmt_possible_actions: Cmt_utils.cmt_action list; } type error = Not_a_typedtree of string @@ -111,6 +112,8 @@ val set_saved_types : binary_part list -> unit val record_value_dependency : Types.value_description -> Types.value_description -> unit +val resave_cmt_with_possible_actions : unit -> unit + (* val is_magic_number : string -> bool diff --git a/compiler/ml/cmt_utils.ml b/compiler/ml/cmt_utils.ml new file mode 100644 index 0000000000..b213179f84 --- /dev/null +++ b/compiler/ml/cmt_utils.ml @@ -0,0 +1,12 @@ +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 970634be03..f3d04b0b60 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 1534837789..e716eec124 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -554,6 +554,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\ @@ -612,6 +621,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\ @@ -669,6 +687,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 0dae8985bf..3e4df480ec 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -2197,7 +2197,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 ff3671b681..6a0ad0de75 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) | _ -> ()) | _ -> () @@ -801,7 +808,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 0dbddd4881..8a03aeacfa 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 0000000000..c9d11ea0d9 --- /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 0000000000..4ba8b400c5 --- /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 0000000000..14d40822db --- /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 0000000000..67a9a9ea2e --- /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 0000000000..b83a148553 --- /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 0000000000..c3da54ce39 --- /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 0000000000..ad461b66f6 --- /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 0000000000..d841d248e0 --- /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 0000000000..674fb45769 --- /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 0000000000..d52a39ecaf --- /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 0000000000..d3e7f5a6ec --- /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 0000000000..89670b250e --- /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 0000000000..bfc62e529c --- /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 0000000000..71ee8d7738 --- /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 88f7ffa575..512c243266 100644 --- a/tools/bin/main.ml +++ b/tools/bin/main.ml @@ -109,6 +109,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 1722fdda07..f055fc3302 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1292,3 +1292,56 @@ module ExtractCodeblocks = struct ]) |> Protocol.array) end + +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 4c78cf4fd242312893a9b692d5365124578f2c4e Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sat, 26 Jul 2025 22:04:17 +0200 Subject: [PATCH 02/40] 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 8a03aeacfa..af2d4caf24 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 4ba8b400c5..0d3e13f2d0 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 14d40822db..c197469c74 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 67a9a9ea2e..8e5c1faaf0 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 b83a148553..9bde3d17d5 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 c3da54ce39..f5e6400113 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 ad461b66f6..9ff0ec466f 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 71ee8d7738..5f228350a6 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 512c243266..b9d31a4c97 100644 --- a/tools/bin/main.ml +++ b/tools/bin/main.ml @@ -110,12 +110,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 f055fc3302..2ed9ec6222 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1294,6 +1294,144 @@ module ExtractCodeblocks = struct end 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 647117be0e5c888995299720cf70fd5bdf92f483 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sat, 26 Jul 2025 22:05:36 +0200 Subject: [PATCH 03/40] map --- tools/src/tools.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 2ed9ec6222..ec45397e14 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1343,6 +1343,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 079efb0ed5e573629770b95e77a874cda4b80cda Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sat, 26 Jul 2025 22:16:58 +0200 Subject: [PATCH 04/40] 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 b213179f84..ca4764cb11 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -3,6 +3,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 e716eec124..c3dc260df5 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -320,6 +320,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\ @@ -413,6 +415,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 0000000000..3aab13b1c0 --- /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 0000000000..caf49c133c --- /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 0000000000..51247f6c6c --- /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 0000000000..fda89aa400 --- /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 5f228350a6..3b7cb68ded 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 ec45397e14..d8fea0e2e0 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1342,9 +1342,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 { @@ -1388,7 +1391,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 @@ -1450,37 +1458,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 bbaaa4332f511d55f8b730620282bfa5001260a5 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sat, 26 Jul 2025 22:21:49 +0200 Subject: [PATCH 05/40] 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 ca4764cb11..74aa684de4 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -7,6 +7,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 c3dc260df5..06a380f946 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -402,6 +402,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 0000000000..3f7d7b2c63 --- /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 0000000000..1451c3f3d8 --- /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 d8fea0e2e0..b96dec359a 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1346,6 +1346,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 3f96d51d33374cc98ffe21cb791a6bbb24ec5426 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sat, 26 Jul 2025 22:28:26 +0200 Subject: [PATCH 06/40] 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 74aa684de4..596671b651 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -8,6 +8,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 06a380f946..4529163d5d 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -343,6 +343,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 0000000000..29fe44ad72 --- /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 0000000000..541be0e3ce --- /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 b96dec359a..d78838280e 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1412,9 +1412,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 94a5fab82b389498b8fc33594f19b016ff53b508 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sat, 26 Jul 2025 22:33:59 +0200 Subject: [PATCH 07/40] 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 4529163d5d..da0493dbaf 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -433,6 +433,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 0000000000..041f6910bb --- /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 0000000000..4b203b92ce --- /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 d78838280e..53cf3964c5 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1346,6 +1346,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 | { @@ -1422,6 +1427,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 bb31a5fbf0f961fdbc3b0eeeffadcd3b90566d37 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sat, 26 Jul 2025 22:43:31 +0200 Subject: [PATCH 08/40] 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 da0493dbaf..cf93382635 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -464,6 +464,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 "@,\ @,\ @@ -480,6 +486,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 0000000000..7e2793ec41 --- /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 0000000000..b4059e242b --- /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 53cf3964c5..6e04d9b22e 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1339,6 +1339,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) -> @@ -1397,7 +1398,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 00846d7752f0c1cd16f301801b6fcd913ab6382f Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sat, 26 Jul 2025 22:59:55 +0200 Subject: [PATCH 09/40] 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 596671b651..b97ee3a4d9 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -9,6 +9,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 cf93382635..fa3225bead 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -515,6 +515,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 "@,\ @,\ @@ -533,6 +534,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 "@,\ @,\ @@ -551,6 +553,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 "@,\ @,\ @@ -798,6 +801,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\ @@ -808,6 +812,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 6a0ad0de75..867edd81bd 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -4322,6 +4322,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.@]" @@ -4329,6 +4330,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.@]" @@ -4418,6 +4420,7 @@ let report_error env loc ppf error = | Apply_wrong_label (l, ty) -> let print_message ppf = function | Noloc.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@}." @@ -4434,6 +4437,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 @@ -4652,12 +4656,14 @@ 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) |> String.concat ", "); 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 ", "); @@ -4704,25 +4710,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 0000000000..5fbfedf416 --- /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 0000000000..5f9073f699 --- /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 6e04d9b22e..8001e5a9a6 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1347,6 +1347,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 83a8667921e7e84e39ae364af0229ecf0cc4f960 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sun, 27 Jul 2025 20:41:42 +0200 Subject: [PATCH 10/40] more todo comments for actions that could be useful --- compiler/ext/warnings.ml | 31 +++++++++++++++++++++++++------ compiler/ml/parmatch.ml | 2 ++ compiler/ml/typecore.ml | 2 ++ compiler/syntax/src/res_core.ml | 1 + 4 files changed, 30 insertions(+), 6 deletions(-) diff --git a/compiler/ext/warnings.ml b/compiler/ext/warnings.ml index f799100a36..d505e877ff 100644 --- a/compiler/ext/warnings.ml +++ b/compiler/ext/warnings.ml @@ -380,6 +380,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\ @@ -395,11 +397,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\ @@ -420,7 +428,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. Please disambiguate if this is wrong." @@ -428,12 +438,16 @@ let message = function | Ambiguous_name (_slist, tl, true) -> "these field labels belong to several types: " ^ String.concat " " tl ^ "\nThe first one was selected. Please disambiguate if this is wrong." - | Nonoptional_label s -> "the label " ^ s ^ " is not optional." + | Nonoptional_label s -> + (* TODO(actions) When does this happen? *) + "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) -> @@ -475,10 +489,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\ @@ -497,6 +514,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 3e4df480ec..07e5dd6a6a 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -2051,6 +2051,7 @@ let do_check_partial ?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 @@ -2211,6 +2212,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 867edd81bd..4208e2caf1 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -2757,6 +2757,7 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected 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 @@ -4657,6 +4658,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 30adeea5ee..4c27f6c9de 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -113,6 +113,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 22de783df29ddb587e265c10be18ea572e853f11 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sun, 27 Jul 2025 20:42:01 +0200 Subject: [PATCH 11/40] 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 5f9073f699..bcb56f917c 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 d8ee98e2907f9df2b350b233e279df6499f9576e Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sun, 27 Jul 2025 21:57:31 +0200 Subject: [PATCH 12/40] 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 f3d04b0b60..02f7393d13 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 07e5dd6a6a..e38600ebee 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -2028,6 +2028,7 @@ let do_check_partial ?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 :: _ -> ( @@ -2146,6 +2147,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) @@ -2193,6 +2195,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 @@ -2200,7 +2208,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; @@ -2212,7 +2219,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 ed63ecbdf1..2784f6bc46 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 4208e2caf1..c0e7e74651 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -1405,6 +1405,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) @@ -2910,7 +2915,9 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected 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 @@ -3621,6 +3628,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 @@ -3682,6 +3690,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_loc l' then + (* TODO(actions) Add ? to make argument optional *) Location.prerr_warning sarg0.pexp_loc (Warnings.Nonoptional_label (Printtyp.string_of_label l)); ( sargs, @@ -4183,6 +4192,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) -> @@ -4253,6 +4263,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 360354600c..e1b85a836e 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -1894,6 +1894,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 53758e26c1..e5b12c8ff6 100644 --- a/compiler/ml/typetexp.ml +++ b/compiler/ml/typetexp.ml @@ -729,6 +729,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 ") @@ -775,6 +776,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`@]" @@ -782,6 +784,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 \ @@ -872,6 +875,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 fe9513cfcc7b370d652039aa4ba116235053e108 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sun, 27 Jul 2025 22:25:26 +0200 Subject: [PATCH 13/40] 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 d505e877ff..05ec638a54 100644 --- a/compiler/ext/warnings.ml +++ b/compiler/ext/warnings.ml @@ -701,3 +701,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 59971b94be..a23e4a0be5 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 b97ee3a4d9..5b0e71c349 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -15,3 +15,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 02f7393d13..9f02867578 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 19de2b7125..fbba381a7d 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 1e4b7c404048fa5de836ca96261c3881dfd69cbf Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sun, 27 Jul 2025 22:28:32 +0200 Subject: [PATCH 14/40] 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 5b0e71c349..b437fb783f 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -20,6 +20,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 e38600ebee..c7621d746c 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -2195,25 +2195,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 a8bcbffd6b7dcd3a3c2f5f084c17647ec5937187 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sun, 27 Jul 2025 22:51:21 +0200 Subject: [PATCH 15/40] 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 e2f4d6cad0..5a12a23280 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) @@ -287,7 +288,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 @@ -475,6 +476,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 745fdb8d20..15187501e3 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 9934bcefb86fef874df3c809dfe386a00cc1b137 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sun, 27 Jul 2025 22:52:13 +0200 Subject: [PATCH 16/40] 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 b437fb783f..1d61308354 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -10,6 +10,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} @@ -23,6 +25,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 0000000000..a023a16d76 --- /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 0000000000..df06e64605 --- /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 8001e5a9a6..965026dcab 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1319,6 +1319,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 c59629937d5e8c8fdbe6ea77653394b6b7c03372 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sun, 27 Jul 2025 22:54:36 +0200 Subject: [PATCH 17/40] 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 4380ca1af2..bea489df60 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 @@ -289,7 +290,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; @@ -489,6 +490,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 8c7b7a5e9f..c63aa94b6d 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 d85b4d079a4c1268364a1301181e45f3af552ae3 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sun, 27 Jul 2025 22:54:56 +0200 Subject: [PATCH 18/40] 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 df06e64605..fae6fd1b3f 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 c2c6aae0ca351a9b0a3070fdbc0ed4b8de9e062e Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 08:28:19 +0200 Subject: [PATCH 19/40] 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 e5b12c8ff6..7b7e8a6e0a 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 @@ -134,7 +134,9 @@ let find_all_labels = let find_value 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 loc decl.val_attributes (Path.name path); r @@ -720,21 +722,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 = @@ -742,7 +744,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) @@ -774,7 +776,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 @@ -846,7 +848,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) -> @@ -855,12 +857,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 -> ( @@ -875,7 +887,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 19f7fa46b9..912a207245 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 0000000000..060aceca5a --- /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 0000000000..dc6051081d --- /dev/null +++ b/tests/build_tests/actions/fixtures/Actions_SpellcheckIdent.res @@ -0,0 +1,2 @@ +let aaaaa = 10 +let b = aaaab From e8558cea9c5095caca014a870c99a86fdd2bb8dc Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 09:02:30 +0200 Subject: [PATCH 20/40] 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 a023a16d76..ee3ddd6e27 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 0000000000..827b646e0a --- /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 fae6fd1b3f..ce8db0b896 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 0000000000..080861e1f6 --- /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 3b7cb68ded..51d7e47e6f 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 b9d31a4c97..46df309ac7 100644 --- a/tools/bin/main.ml +++ b/tools/bin/main.ml @@ -111,12 +111,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 965026dcab..0bffd092a3 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1321,7 +1321,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 -> @@ -1492,9 +1508,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 @@ -1511,7 +1538,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 @@ -1529,7 +1557,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 f4d7c8a176b60323061226c368a20f220ca5658d Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 09:39:03 +0200 Subject: [PATCH 21/40] 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 1d61308354..db797501d5 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -15,6 +15,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 3aab13b1c0..a651c5e659 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 0d3e13f2d0..2294ba4390 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 c197469c74..b72e89cc8d 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 0000000000..bcfb045c57 --- /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 7e2793ec41..d9261ca3f3 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 ee3ddd6e27..0214add773 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 caf49c133c..6071c2d522 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 827b646e0a..49ff8b3161 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 041f6910bb..eb04e4e08e 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 29fe44ad72..4af04fc8f7 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 5fbfedf416..f44fc78b2a 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 3f7d7b2c63..f448225c03 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 060aceca5a..6a0af8a6fa 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 8e5c1faaf0..8032bbd562 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 9bde3d17d5..00e0fba7b1 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 f5e6400113..57c8bd6a08 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 9ff0ec466f..d51669487b 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 0000000000..cbf92a5557 --- /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 0bffd092a3..6da38d571b 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1584,7 +1584,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 ef781393c2818f026db6c86ffcd2b45c6eb10ec3 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 09:50:33 +0200 Subject: [PATCH 22/40] 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 db797501d5..1c344c4a91 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -9,6 +9,7 @@ type action_type = | ReplaceWithPolymorphicVariantConstructor of {constructor_name: string} | RewriteObjectToRecord | RewriteArrayToTuple + | RewriteIdentToModule of {module_name: string} | RewriteIdent of {new_ident: Longident.t} | PrefixVariableWithUnderscore | RemoveUnusedVariable @@ -28,6 +29,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 7b7e8a6e0a..cbe3139b25 100644 --- a/compiler/ml/typetexp.ml +++ b/compiler/ml/typetexp.ml @@ -873,35 +873,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 bcfb045c57..a0180da07f 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 6da38d571b..ce79676e18 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1486,6 +1486,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) @@ -1578,6 +1594,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 4ccbb56b79bced8e33493cb9cb80415202070872 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 10:11:32 +0200 Subject: [PATCH 23/40] 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 05ec638a54..afd3d5d68c 100644 --- a/compiler/ext/warnings.ml +++ b/compiler/ext/warnings.ml @@ -380,8 +380,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\ @@ -397,9 +395,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 1c344c4a91..86255ac966 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -14,6 +14,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 @@ -53,7 +56,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 e1b85a836e..360354600c 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -1894,7 +1894,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 0000000000..44fc18dd3e --- /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 0000000000..6c1d0f536f --- /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 ce79676e18..9bca940485 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1318,7 +1318,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 73ac801b3e05e5ae18b833b7fb29f21f5bbd105e Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 10:32:00 +0200 Subject: [PATCH 24/40] 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 86255ac966..ae20db1d81 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -13,6 +13,8 @@ type action_type = | RewriteIdent of {new_ident: Longident.t} | PrefixVariableWithUnderscore | RemoveUnusedVariable + | RemoveUnusedType + | RemoveUnusedModule (* TODO: - Unused var in patterns (and aliases )*) @@ -36,6 +38,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 ".") @@ -69,6 +73,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 9f02867578..5cd43e3179 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 c7621d746c..77accfc3e4 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -2206,7 +2206,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 c0e7e74651..37198d8b90 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) @@ -3628,7 +3624,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 @@ -4192,7 +4187,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 0000000000..16b1575b07 --- /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 0000000000..fea4ca49d7 --- /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 0000000000..3400742ca3 --- /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 0000000000..813bd607e0 --- /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 9bca940485..add8bc670f 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1316,6 +1316,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 @@ -1606,7 +1631,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 f020c603d73ae189f4d43217c4078f561824bcec Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 11:48:37 +0200 Subject: [PATCH 25/40] 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 afd3d5d68c..d141f1b28d 100644 --- a/compiler/ext/warnings.ml +++ b/compiler/ext/warnings.ml @@ -397,9 +397,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 *) @@ -424,9 +422,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. Please disambiguate if this is wrong." diff --git a/compiler/ml/cmt_utils.ml b/compiler/ml/cmt_utils.ml index ae20db1d81..a82a4a22fc 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -15,6 +15,7 @@ type action_type = | RemoveUnusedVariable | RemoveUnusedType | RemoveUnusedModule + | RemoveRecFlag (* TODO: - Unused var in patterns (and aliases )*) @@ -49,6 +50,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 @@ -82,7 +84,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 0000000000..9ba4ea151b --- /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 0000000000..7c3ee1d2cc --- /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 add8bc670f..05e7ff051b 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1298,6 +1298,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 = @@ -1518,6 +1536,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} ), @@ -1633,7 +1662,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 8ba0b91756976940b6c459f239f1f1aaa796c9a9 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 11:48:57 +0200 Subject: [PATCH 26/40] 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 7c3ee1d2cc..15dbc12e5c 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 15b37ae616ad5c9cc51e2cdbdd01d24d2ea30c03 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 12:00:37 +0200 Subject: [PATCH 27/40] 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 d141f1b28d..26d0520f7a 100644 --- a/compiler/ext/warnings.ml +++ b/compiler/ext/warnings.ml @@ -434,12 +434,10 @@ let message = function (* TODO(actions) When does this happen? *) "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 a82a4a22fc..479111ccee 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -16,6 +16,7 @@ type action_type = | RemoveUnusedType | RemoveUnusedModule | RemoveRecFlag + | ForceOpen (* TODO: - Unused var in patterns (and aliases )*) @@ -51,6 +52,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 @@ -87,6 +89,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 0000000000..b2746b7515 --- /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 0000000000..965c62eb8c --- /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 05e7ff051b..3a6e6052bf 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1308,7 +1308,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 = @@ -1663,7 +1680,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 fe165b837ed702ddb2868413a20a0a1751c1e861 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 12:06:40 +0200 Subject: [PATCH 28/40] cleanup --- compiler/ext/warnings.ml | 4 +--- compiler/ml/cmt_utils.ml | 16 +++++++++++++--- compiler/ml/env.ml | 2 -- compiler/ml/typecore.ml | 4 ---- compiler/ml/typetexp.ml | 3 +-- 5 files changed, 15 insertions(+), 14 deletions(-) diff --git a/compiler/ext/warnings.ml b/compiler/ext/warnings.ml index 26d0520f7a..9deb8bf059 100644 --- a/compiler/ext/warnings.ml +++ b/compiler/ext/warnings.ml @@ -479,9 +479,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 479111ccee..e60d73f425 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -83,14 +83,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 5cd43e3179..970634be03 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 37198d8b90..28711d9c3c 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -1405,7 +1405,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 @@ -2758,7 +2757,6 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected 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 @@ -3685,7 +3683,6 @@ 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_loc l' then - (* TODO(actions) Add ? to make argument optional *) Location.prerr_warning sarg0.pexp_loc (Warnings.Nonoptional_label (Printtyp.string_of_label l)); ( sargs, @@ -4257,7 +4254,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 cbe3139b25..51c09c9d9c 100644 --- a/compiler/ml/typetexp.ml +++ b/compiler/ml/typetexp.ml @@ -731,7 +731,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 ") @@ -778,7 +777,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 ed90c6480fa0fd3f6883043e092d3b41b1520fee Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 12:12:10 +0200 Subject: [PATCH 29/40] 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 e60d73f425..6a805f02c9 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -16,6 +16,7 @@ type action_type = | RemoveUnusedType | RemoveUnusedModule | RemoveRecFlag + | RemoveRecordSpread | ForceOpen (* TODO: @@ -53,6 +54,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 @@ -88,6 +90,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 === @@ -97,7 +102,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 0000000000..23603dde2f --- /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 0000000000..434279bbfc --- /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 3a6e6052bf..20c05c8dba 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1457,6 +1457,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} -> @@ -1681,7 +1687,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 603b066a7ce953e0c94de8a81090baa7ff4c5697 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 12:15:00 +0200 Subject: [PATCH 30/40] 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 6a805f02c9..74d678ca88 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -98,8 +98,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 cdb57c55abf28db48947e934379d0f01cc3b0611 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 12:30:05 +0200 Subject: [PATCH 31/40] 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 9deb8bf059..0a5130e51b 100644 --- a/compiler/ext/warnings.ml +++ b/compiler/ext/warnings.ml @@ -502,8 +502,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 74d678ca88..d7e8e4252e 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -18,6 +18,8 @@ type action_type = | RemoveRecFlag | RemoveRecordSpread | ForceOpen + | AssignToUnderscore + | PipeToIgnore (* TODO: - Unused var in patterns (and aliases )*) @@ -55,6 +57,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 @@ -102,7 +106,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 0000000000..9a0bc40eb3 --- /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 0000000000..65175a6061 --- /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 0000000000..31495f7ba2 --- /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 0000000000..d5a735c59c --- /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 20c05c8dba..495c544e40 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1316,7 +1316,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 = @@ -1457,6 +1482,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 _)} -> @@ -1688,7 +1735,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 a0c3724c586b48c89c80b054aaf7d964978e0d09 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 12:33:06 +0200 Subject: [PATCH 32/40] 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 0a5130e51b..e140738930 100644 --- a/compiler/ext/warnings.ml +++ b/compiler/ext/warnings.ml @@ -399,9 +399,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\ @@ -483,7 +481,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 d7e8e4252e..f5f560e342 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -97,6 +97,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 === @@ -104,12 +109,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 3e56f6309f23f0ee949d7a190492ada6004803c4 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 13:45:18 +0200 Subject: [PATCH 33/40] 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 9a0bc40eb3..964847798a 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 65175a6061..a31b78fdf2 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 0214add773..08ab3a728d 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 9ba4ea151b..2397491dae 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 16b1575b07..3605fa5032 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 44fc18dd3e..38591b776d 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 49ff8b3161..6bd0933076 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 495c544e40..22d7422725 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1743,7 +1743,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 9c275538977788f03f85c9e4bdb1d854c5559516 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 14:46:39 +0200 Subject: [PATCH 34/40] make optional arg labelled --- compiler/ml/cmt_utils.ml | 14 ++++++- compiler/ml/typecore.ml | 1 - .../Actions_MakeArgNonOptional_applied.res | 9 +++++ .../fixtures/Actions_MakeArgNonOptional.res | 5 +++ tools/src/tools.ml | 37 ++++++++++++++++++- 5 files changed, 63 insertions(+), 3 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 f5f560e342..135059dfdf 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -11,6 +11,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 @@ -59,6 +60,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 @@ -102,6 +108,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 === @@ -110,7 +123,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/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 28711d9c3c..151e911a77 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -4422,7 +4422,6 @@ let report_error env loc ppf error = | Apply_wrong_label (l, ty) -> let print_message ppf = function | Noloc.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@}." 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 0000000000..cf9ab078a6 --- /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 0000000000..daa6d2c435 --- /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 22d7422725..3631341edd 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1606,6 +1606,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), @@ -1737,7 +1771,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 8986037c593173088dd2cf57154e2b7de8728e18 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 14:49:55 +0200 Subject: [PATCH 35/40] 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 fa3225bead..0eb3fac655 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -553,7 +553,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 0000000000..21458bc809 --- /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 0000000000..9c8a4e4e65 --- /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 884a7da257de1d504be0ae3ad0c112bee8d30382 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 14:56:32 +0200 Subject: [PATCH 36/40] partially apply function --- compiler/ml/cmt_utils.ml | 2 ++ compiler/ml/typecore.ml | 11 ++++++++--- .../Actions_PartiallyApplyFunction_applied.res | 7 +++++++ .../fixtures/Actions_PartiallyApplyFunction.res | 3 +++ tools/src/tools.ml | 11 +++++++++++ 5 files changed, 31 insertions(+), 3 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 135059dfdf..ae6b452d76 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -21,6 +21,7 @@ type action_type = | ForceOpen | AssignToUnderscore | PipeToIgnore + | PartiallyApplyFunction (* TODO: - Unused var in patterns (and aliases )*) @@ -65,6 +66,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 151e911a77..e88da9b165 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -4656,13 +4656,18 @@ let report_error env loc ppf error = if not is_fallback then fprintf ppf "@,"; - if List.length missing_required_args > 0 then + 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 ", ")); if List.length superfluous_args > 0 then (* TODO(actions) Remove arguments *) 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 0000000000..069389af17 --- /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 0000000000..f608aa3bea --- /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 3631341edd..9922f351e9 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1606,6 +1606,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 = @@ -1772,6 +1781,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 ee9710d90d8824d8ba025625f5cf6fc562e6f3d8 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 15:07:59 +0200 Subject: [PATCH 37/40] 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 ae6b452d76..bc33a002bc 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -22,6 +22,7 @@ type action_type = | AssignToUnderscore | PipeToIgnore | PartiallyApplyFunction + | InsertMissingArguments of {missing_args: Asttypes.Noloc.arg_label list} (* TODO: - Unused var in patterns (and aliases )*) @@ -67,6 +68,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 e88da9b165..047e34f1ff 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -4657,7 +4657,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 0000000000..99123d0b8a --- /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 069389af17..7d79033803 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 0000000000..79b617bdb4 --- /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 9922f351e9..6aef6940df 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1606,6 +1606,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 -> @@ -1783,7 +1800,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 c4cf0e65c1ff7d2ad27117d14ae0cc405f5e72e7 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 28 Jul 2025 16:17:56 +0200 Subject: [PATCH 38/40] 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 bea489df60..a0aeb53bb7 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; @@ -311,11 +313,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; @@ -401,12 +399,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; @@ -530,4 +523,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 c63aa94b6d..1302b5ea1a 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 5a12a23280..bc6e0fcf1c 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; @@ -307,10 +310,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) @@ -393,12 +393,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) -> @@ -511,6 +506,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 15187501e3..299d59d5de 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 bc33a002bc..5fdfef33dd 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -23,6 +23,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 )*) @@ -77,6 +78,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 0eb3fac655..14092c6b45 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -515,7 +515,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 "@,\ @,\ @@ -534,7 +539,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 0000000000..6c91a4a32d --- /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 0000000000..c4d8af901b --- /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 6aef6940df..27cdf3952e 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1294,10 +1294,39 @@ module ExtractCodeblocks = struct end 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 = @@ -1802,7 +1831,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 69ccd838a6ba537e428a1bdabfa3bb8ca4e7a6ef Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Tue, 29 Jul 2025 22:42:16 +0200 Subject: [PATCH 39/40] 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 5fdfef33dd..671e2c5751 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -24,6 +24,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 )*) @@ -81,6 +82,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 51c09c9d9c..089fdb567b 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 @@ -128,8 +132,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 env loc lid = Env.check_value_name (Longident.last lid) loc; @@ -168,8 +174,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. *) @@ -936,10 +943,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 \ @@ -951,14 +965,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 \ @@ -967,7 +982,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 \ @@ -978,8 +993,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 912a207245..ac10f6d4a2 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 27cdf3952e..f90923374e 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1293,6 +1293,24 @@ module ExtractCodeblocks = struct |> Protocol.array) end +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 = @@ -1635,6 +1653,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 -> @@ -1833,7 +1877,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 2a5d63726e2a1afc22c669306b5a7e936523b165 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Tue, 29 Jul 2025 22:42:50 +0200 Subject: [PATCH 40/40] 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 0000000000..11bfbf38f2 --- /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 0000000000..9d71abf6d5 --- /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