From 01b10abf52cfd0886100f13496c9300aea87e186 Mon Sep 17 00:00:00 2001 From: tsnobip Date: Sat, 28 Mar 2026 10:35:02 +0100 Subject: [PATCH 01/22] destructure record rest elements - fixes #8311 --- analysis/reanalyze/src/dead_value.ml | 2 +- analysis/src/completion_front_end.ml | 2 +- analysis/src/completion_patterns.ml | 4 +- analysis/src/dump_ast.ml | 2 +- analysis/src/hint.ml | 2 +- analysis/src/process_cmt.ml | 2 +- analysis/src/process_extra.ml | 2 +- analysis/src/semantic_tokens.ml | 2 +- analysis/src/signature_help.ml | 3 +- analysis/src/xform.ml | 2 +- compiler/common/pattern_printer.ml | 4 +- compiler/core/lam_analysis.ml | 2 +- compiler/core/lam_compile_primitive.ml | 12 ++ compiler/core/lam_convert.ml | 2 + compiler/core/lam_primitive.ml | 7 +- compiler/core/lam_primitive.mli | 1 + compiler/core/lam_print.ml | 2 + .../frontend/ast_tuple_pattern_flatten.ml | 2 +- compiler/frontend/bs_ast_mapper.ml | 6 +- compiler/ml/ast_helper.ml | 2 +- compiler/ml/ast_helper.mli | 1 + compiler/ml/ast_iterator.ml | 2 +- compiler/ml/ast_mapper.ml | 6 +- compiler/ml/ast_mapper_to0.ml | 2 +- compiler/ml/depend.ml | 2 +- compiler/ml/lambda.ml | 1 + compiler/ml/lambda.mli | 1 + compiler/ml/matching.ml | 77 ++++++-- compiler/ml/parmatch.ml | 57 +++--- compiler/ml/parsetree.ml | 7 +- compiler/ml/pprintast.ml | 2 +- compiler/ml/printast.ml | 2 +- compiler/ml/printlambda.ml | 2 + compiler/ml/printtyped.ml | 2 +- compiler/ml/rec_check.ml | 4 +- compiler/ml/tast_iterator.ml | 2 +- compiler/ml/tast_mapper.ml | 4 +- compiler/ml/typecore.ml | 178 +++++++++++++++++- compiler/ml/typecore.mli | 6 + compiler/ml/typedtree.ml | 23 ++- compiler/ml/typedtree.mli | 9 + compiler/ml/typedtree_iter.ml | 2 +- compiler/syntax/src/res_ast_debugger.ml | 2 +- compiler/syntax/src/res_comments_table.ml | 2 +- compiler/syntax/src/res_core.ml | 80 +++++++- compiler/syntax/src/res_printer.ml | 36 +++- .../errors/other/expected/spread.res.txt | 16 +- .../grammar/pattern/expected/record.res.txt | 10 +- .../data/parsing/grammar/pattern/record.res | 16 ++ .../pattern/expected/parenthesized.res.txt | 2 +- .../recovery/pattern/expected/record.res.txt | 16 +- tests/tests/src/record_rest_test.mjs | 35 ++++ tests/tests/src/record_rest_test.res | 41 ++++ 53 files changed, 577 insertions(+), 134 deletions(-) create mode 100644 tests/tests/src/record_rest_test.mjs create mode 100644 tests/tests/src/record_rest_test.res diff --git a/analysis/reanalyze/src/dead_value.ml b/analysis/reanalyze/src/dead_value.ml index aa82de7f77d..a10a3f8d909 100644 --- a/analysis/reanalyze/src/dead_value.ml +++ b/analysis/reanalyze/src/dead_value.ml @@ -235,7 +235,7 @@ let collect_pattern ~config ~refs : fun super self pat -> let pos_from = pat.Typedtree.pat_loc.loc_start in (match pat.pat_desc with - | Typedtree.Tpat_record (cases, _clodsedFlag) -> + | Typedtree.Tpat_record (cases, _clodsedFlag, _rest) -> cases |> List.iter (fun (_loc, {Types.lbl_loc = {loc_start = pos_to}}, _pat, _) -> if !Config.analyze_types then diff --git a/analysis/src/completion_front_end.ml b/analysis/src/completion_front_end.ml index aeaf7657903..e0bc67bce69 100644 --- a/analysis/src/completion_front_end.ml +++ b/analysis/src/completion_front_end.ml @@ -517,7 +517,7 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file (NPolyvariantPayload {item_num = 0; constructor_name = txt} :: pattern_path) ?context_path p - | Ppat_record (fields, _) -> + | Ppat_record (fields, _, _rest) -> Ext_list.iter fields (fun {lid = fname; x = p} -> match fname with | {Location.txt = Longident.Lident fname} -> diff --git a/analysis/src/completion_patterns.ml b/analysis/src/completion_patterns.ml index cc1a270cab7..16b6ae886df 100644 --- a/analysis/src/completion_patterns.ml +++ b/analysis/src/completion_patterns.ml @@ -106,12 +106,12 @@ and traverse_pattern (pat : Parsetree.pattern) ~pattern_path ~loc_has_cursor [Completable.NTupleItem {item_num}] @ pattern_path) ~result_from_found_item_num:(fun item_num -> [Completable.NTupleItem {item_num = item_num + 1}] @ pattern_path) - | Ppat_record ([], _) -> + | Ppat_record ([], _, _rest) -> (* Empty fields means we're in a record body `{}`. Complete for the fields. *) some_if_has_cursor ("", [Completable.NRecordBody {seen_fields = []}] @ pattern_path) "Ppat_record(empty)" - | Ppat_record (fields, _) -> ( + | Ppat_record (fields, _, _rest) -> ( let field_with_cursor = ref None in let field_with_pat_hole = ref None in Ext_list.iter fields (fun {lid = fname; x = f} -> diff --git a/analysis/src/dump_ast.ml b/analysis/src/dump_ast.ml index 0ebb44c0d5a..6301af8f897 100644 --- a/analysis/src/dump_ast.ml +++ b/analysis/src/dump_ast.ml @@ -101,7 +101,7 @@ let rec print_pattern pattern ~pos ~indentation = | None -> "" | Some pat -> "," ^ print_pattern pat ~pos ~indentation) ^ ")" - | Ppat_record (fields, _) -> + | Ppat_record (fields, _, _rest) -> "Ppat_record(\n" ^ add_indentation (indentation + 1) ^ "fields:\n" diff --git a/analysis/src/hint.ml b/analysis/src/hint.ml index 7206a6beb8f..3f9f8e98ff2 100644 --- a/analysis/src/hint.ml +++ b/analysis/src/hint.ml @@ -42,7 +42,7 @@ let inlay ~source ~kind_file ~pos ~max_length ~full ~state ~debug = let rec process_pattern (pat : Parsetree.pattern) = match pat.ppat_desc with | Ppat_tuple pl -> pl |> List.iter process_pattern - | Ppat_record (fields, _) -> + | Ppat_record (fields, _, _rest) -> Ext_list.iter fields (fun {x = p} -> process_pattern p) | Ppat_array fields -> fields |> List.iter process_pattern | Ppat_var {loc} -> push loc Type diff --git a/analysis/src/process_cmt.ml b/analysis/src/process_cmt.ml index 4e6cca03bf5..ab7aa7d46f7 100644 --- a/analysis/src/process_cmt.ml +++ b/analysis/src/process_cmt.ml @@ -517,7 +517,7 @@ let rec for_structure_item ~(env : Shared_types.Env.t) ~(exported : Exported.t) | Tpat_tuple pats | Tpat_array pats | Tpat_construct (_, _, pats) -> pats |> List.iter (fun p -> handle_pattern [] p) | Tpat_or (p, _, _) -> handle_pattern [] p - | Tpat_record (items, _) -> + | Tpat_record (items, _, _rest) -> items |> List.iter (fun (_, _, p, _) -> handle_pattern [] p) | Tpat_variant (_, Some p, _) -> handle_pattern [] p | Tpat_variant (_, None, _) | Tpat_any | Tpat_constant _ -> () diff --git a/analysis/src/process_extra.ml b/analysis/src/process_extra.ml index fcd5c8e1f1d..c2a7bd24508 100644 --- a/analysis/src/process_extra.ml +++ b/analysis/src/process_extra.ml @@ -392,7 +392,7 @@ let pat ~(file : File.t) ~env ~extra (iter : Tast_iterator.iterator) in (* Log.log("Entering pattern " ++ Utils.showLocation(pat_loc)); *) (match pattern.pat_desc with - | Tpat_record (items, _) -> + | Tpat_record (items, _, _rest) -> add_for_record ~env ~extra ~record_type:pattern.pat_type items | Tpat_construct (lident, constructor, _) -> add_for_constructor ~env ~extra pattern.pat_type lident constructor diff --git a/analysis/src/semantic_tokens.ml b/analysis/src/semantic_tokens.ml index 92b3afe8369..bb230f1c7a2 100644 --- a/analysis/src/semantic_tokens.ml +++ b/analysis/src/semantic_tokens.ml @@ -233,7 +233,7 @@ let command ~debug ~emitter ~source ~kind_file = | Ppat_construct ({txt = Lident ("true" | "false")}, _) -> (* Don't emit true or false *) Ast_iterator.default_iterator.pat iterator p - | Ppat_record (cases, _) -> + | Ppat_record (cases, _, _rest) -> Ext_list.iter cases (fun {lid = label} -> emitter |> emit_record_label ~label ~debug); Ast_iterator.default_iterator.pat iterator p diff --git a/analysis/src/signature_help.ml b/analysis/src/signature_help.ml index 493ce3490fa..aca9539536e 100644 --- a/analysis/src/signature_help.ml +++ b/analysis/src/signature_help.ml @@ -685,7 +685,8 @@ let signature_help ~debug ~source ~kind_file ~pos match tuple_item_with_cursor with | None -> -1 | Some i -> i) - | `ConstructorPat (_, {ppat_desc = Ppat_record (fields, _)}) -> ( + | `ConstructorPat (_, {ppat_desc = Ppat_record (fields, _, _rest)}) + -> ( let field_name_with_cursor = fields |> List.find_map diff --git a/analysis/src/xform.ml b/analysis/src/xform.ml index ac12e160357..d5c59eba513 100644 --- a/analysis/src/xform.ml +++ b/analysis/src/xform.ml @@ -78,7 +78,7 @@ module If_then_else = struct in match list_to_pat ~item_to_pat items with | None -> None - | Some pat_items -> Some (mk_pat (Ppat_record (pat_items, Closed)))) + | Some pat_items -> Some (mk_pat (Ppat_record (pat_items, Closed, None)))) | Pexp_record (_, Some _) -> None | _ -> None diff --git a/compiler/common/pattern_printer.ml b/compiler/common/pattern_printer.ml index 603f9808404..754eb2533c0 100644 --- a/compiler/common/pattern_printer.ml +++ b/compiler/common/pattern_printer.ml @@ -76,7 +76,7 @@ let untype typed = | Tpat_variant (label, p_opt, _row_desc) -> let arg = Option.map loop p_opt in mkpat (Ppat_variant (label, arg)) - | Tpat_record (subpatterns, closed_flag) -> + | Tpat_record (subpatterns, closed_flag, _rest) -> let fields, saw_optional_rewrite = List.fold_right (fun (_, lbl, p, opt) (fields, saw_optional_rewrite) -> @@ -97,7 +97,7 @@ let untype typed = subpatterns ([], false) in let closed_flag = if saw_optional_rewrite then Closed else closed_flag in - mkpat (Ppat_record (fields, closed_flag)) + mkpat (Ppat_record (fields, closed_flag, None)) | Tpat_array lst -> mkpat (Ppat_array (List.map loop lst)) in loop typed diff --git a/compiler/core/lam_analysis.ml b/compiler/core/lam_analysis.ml index 29a8d3a1602..8ffc3ea8795 100644 --- a/compiler/core/lam_analysis.ml +++ b/compiler/core/lam_analysis.ml @@ -53,7 +53,7 @@ let rec no_side_effects (lam : Lam.t) : bool = (* whether it's mutable or not *) | Pfield _ | Pval_from_option | Pval_from_option_not_nest (* NOP The compiler already [t option] is the same as t *) - | Pduprecord + | Pduprecord | Precord_spread_new _ (* generic primitives *) | Pobjcomp _ | Pobjorder | Pobjmin | Pobjmax | Pobjtag | Pobjsize (* bool primitives *) diff --git a/compiler/core/lam_compile_primitive.ml b/compiler/core/lam_compile_primitive.ml index e6a7a86a6e3..5c1f131f958 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -609,6 +609,18 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) match args with | [e1] -> E.obj ~dup:e1 [] | _ -> assert false) + | Precord_spread_new excluded -> ( + match args with + | [e1] -> + (* Generate: (({field1, field2, ...rest}) => rest)(source) + This uses JS destructuring to cleanly extract the rest *) + let excluded_str = String.concat ", " excluded in + let code = Printf.sprintf "(({%s, ...__rest}) => __rest)" excluded_str in + E.call + ~info:{arity = Full; call_info = Call_na; call_transformed_jsx = false} + (E.raw_js_code (Exp (Js_function {arity = 1; arrow = true})) code) + [e1] + | _ -> assert false) | Phash -> ( match args with | [e1; e2; e3; e4] -> E.runtime_call Primitive_modules.hash "hash" args diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 9e0bccdaa93..1da0c23109e 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -208,6 +208,8 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = | Psetfield (id, info) -> prim ~primitive:(Psetfield (id, info)) ~args loc | Pduprecord -> prim ~primitive:Pduprecord ~args loc | Ptagged_template -> prim ~primitive:Ptagged_template ~args loc + | Precord_spread_new excluded -> + prim ~primitive:(Precord_spread_new excluded) ~args loc | Praise _ -> prim ~primitive:Praise ~args loc | Pobjcomp x -> prim ~primitive:(Pobjcomp x) ~args loc | Pobjorder -> prim ~primitive:Pobjorder ~args loc diff --git a/compiler/core/lam_primitive.ml b/compiler/core/lam_primitive.ml index 974aff095b0..73fad3d2538 100644 --- a/compiler/core/lam_primitive.ml +++ b/compiler/core/lam_primitive.ml @@ -42,6 +42,7 @@ type t = | Pduprecord (* Tagged template literal: [tag; strings_array; values_array] *) | Ptagged_template + | Precord_spread_new of string list (* External call *) | Pjs_call of { prim_name: string; @@ -228,9 +229,9 @@ let eq_primitive_approx (lhs : t) (rhs : t) = | Pnull_to_opt | Pnull_undefined_to_opt | Pis_null | Pis_not_none | Psome | Psome_not_nest | Pis_undefined | Pis_null_undefined | Pimport | Ptypeof | Pfn_arity | Pis_poly_var_block | Pdebugger | Pinit_mod | Pupdate_mod - | Pduprecord | Pmakearray | Parraylength | Parrayrefu | Parraysetu - | Parrayrefs | Parraysets | Pjs_fn_make_unit | Pjs_fn_method | Phash - | Phash_mixstring | Phash_mixint | Phash_finalmix -> + | Pduprecord | Precord_spread_new _ | Pmakearray | Parraylength | Parrayrefu + | Parraysetu | Parrayrefs | Parraysets | Pjs_fn_make_unit | Pjs_fn_method + | Phash | Phash_mixstring | Phash_mixint | Phash_finalmix -> rhs = lhs (* Reachable only via the optimizer's term-equality comparison, which the test suite doesn't exercise for tagged templates. *) diff --git a/compiler/core/lam_primitive.mli b/compiler/core/lam_primitive.mli index 8c0d26a89e1..8a355cc4791 100644 --- a/compiler/core/lam_primitive.mli +++ b/compiler/core/lam_primitive.mli @@ -37,6 +37,7 @@ type t = | Psetfield of int * Lambda.set_field_dbg_info | Pduprecord | Ptagged_template + | Precord_spread_new of string list | Pjs_call of { (* Location.t * [loc] is passed down *) prim_name: string; diff --git a/compiler/core/lam_print.ml b/compiler/core/lam_print.ml index 9408b11aea4..c8e7f29deb7 100644 --- a/compiler/core/lam_print.ml +++ b/compiler/core/lam_print.ml @@ -83,6 +83,8 @@ let primitive ppf (prim : Lam_primitive.t) = let instr = "setfield " in fprintf ppf "%s%i" instr n | Pduprecord -> fprintf ppf "duprecord" + | Precord_spread_new excluded -> + fprintf ppf "record_spread_new(%s)" (String.concat ", " excluded) | Pjs_call {prim_name} -> fprintf ppf "%s[js]" prim_name | Pjs_object_create _ -> fprintf ppf "[js.obj]" | Praise -> fprintf ppf "raise" diff --git a/compiler/frontend/ast_tuple_pattern_flatten.ml b/compiler/frontend/ast_tuple_pattern_flatten.ml index 27fe1e73a85..1955936b99b 100644 --- a/compiler/frontend/ast_tuple_pattern_flatten.ml +++ b/compiler/frontend/ast_tuple_pattern_flatten.ml @@ -64,7 +64,7 @@ let flattern_tuple_pattern_vb (self : Bs_ast_mapper.mapper) } :: acc) | _ -> {pvb_pat; pvb_expr; pvb_loc = vb.pvb_loc; pvb_attributes} :: acc) - | Ppat_record (lid_pats, _), Pexp_pack {pmod_desc = Pmod_ident id} -> + | Ppat_record (lid_pats, _, _rest), Pexp_pack {pmod_desc = Pmod_ident id} -> Ext_list.map_append lid_pats acc (fun {lid; x = pat} -> match lid.txt with | Lident s -> diff --git a/compiler/frontend/bs_ast_mapper.ml b/compiler/frontend/bs_ast_mapper.ml index 7144cc776a5..31696129001 100644 --- a/compiler/frontend/bs_ast_mapper.ml +++ b/compiler/frontend/bs_ast_mapper.ml @@ -433,8 +433,12 @@ module P = struct | Ppat_construct (l, p) -> 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) -> + | Ppat_record (lpl, cf, rest) -> record ~loc ~attrs + ?rest: + (match rest with + | None -> None + | Some p -> Some (sub.pat sub p)) (List.map (fun {lid; x = p; opt} -> {lid = map_loc sub lid; x = sub.pat sub p; opt}) diff --git a/compiler/ml/ast_helper.ml b/compiler/ml/ast_helper.ml index d8d3b350cb4..da26d2ba637 100644 --- a/compiler/ml/ast_helper.ml +++ b/compiler/ml/ast_helper.ml @@ -141,7 +141,7 @@ module Pat = struct let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a) let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b)) let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b)) + let record ?loc ?attrs ?rest a b = mk ?loc ?attrs (Ppat_record (a, b, rest)) let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a) let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b)) let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b)) diff --git a/compiler/ml/ast_helper.mli b/compiler/ml/ast_helper.mli index 6538c50419f..05282cd49fe 100644 --- a/compiler/ml/ast_helper.mli +++ b/compiler/ml/ast_helper.mli @@ -102,6 +102,7 @@ module Pat : sig val record : ?loc:loc -> ?attrs:attrs -> + ?rest:pattern -> pattern record_element list -> closed_flag -> pattern diff --git a/compiler/ml/ast_iterator.ml b/compiler/ml/ast_iterator.ml index 474fec12d68..75a55d88d0d 100644 --- a/compiler/ml/ast_iterator.ml +++ b/compiler/ml/ast_iterator.ml @@ -407,7 +407,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) -> + | Ppat_record (lpl, _cf, _rest) -> List.iter (fun {lid; x = pat} -> iter_loc sub lid; diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index 7953771b4c8..f7c9b8031cb 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -397,8 +397,12 @@ module P = struct | Ppat_construct (l, p) -> 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) -> + | Ppat_record (lpl, cf, rest) -> record ~loc ~attrs + ?rest: + (match rest with + | None -> None + | Some p -> Some (sub.pat sub p)) (List.map (fun {lid; x = pat; opt} -> {lid = map_loc sub lid; x = sub.pat sub pat; opt}) diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index c204651070e..a5773871577 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -601,7 +601,7 @@ module P = struct | Ppat_construct (l, p) -> 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) -> + | Ppat_record (lpl, cf, _rest) -> record ~loc ~attrs (Ext_list.map lpl (fun {lid; x = p; opt = optional} -> let lid1 = map_loc sub lid in diff --git a/compiler/ml/depend.ml b/compiler/ml/depend.ml index 3a13d4ac003..49c5463b124 100644 --- a/compiler/ml/depend.ml +++ b/compiler/ml/depend.ml @@ -179,7 +179,7 @@ let rec add_pattern bv pat = | Ppat_construct (c, op) -> add bv c; add_opt add_pattern bv op - | Ppat_record (pl, _) -> + | Ppat_record (pl, _, _rest) -> List.iter (fun {lid = lbl; x = p} -> add bv lbl; diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index e078a2a28f8..5324f00aa23 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -177,6 +177,7 @@ type primitive = | Pfield of int * field_dbg_info | Psetfield of int * set_field_dbg_info | Pduprecord + | Precord_spread_new of string list (* excluded field names *) (* External call *) | Pccall of Primitive.description (* Exceptions *) diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 99f399aa0ac..16fe7036d2d 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -146,6 +146,7 @@ type primitive = | Pfield of int * field_dbg_info | Psetfield of int * set_field_dbg_info | Pduprecord + | Precord_spread_new of string list (* excluded field names *) (* External call *) | Pccall of Primitive.description (* Exceptions *) diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index 916646ea08a..8d3912a90c7 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -213,12 +213,12 @@ let ctx_matcher p = | Tpat_tuple args when List.length args = len -> (p, args @ rem) | Tpat_any -> (p, omegas @ rem) | _ -> raise NoMatch) - | Tpat_record (((_, lbl, _, _) :: _ as l), _) -> ( + | Tpat_record (((_, lbl, _, _) :: _ as l), _, _rest) -> ( (* Records are normalized *) let len = Array.length lbl.lbl_all in fun q rem -> match q.pat_desc with - | Tpat_record (((_, lbl', _, _) :: _ as l'), _) + | Tpat_record (((_, lbl', _, _) :: _ as l'), _, _rest') when Array.length lbl'.lbl_all = len -> let l' = all_record_args l' in (p, List.fold_right (fun (_, _, p, _) r -> p :: r) l' rem) @@ -536,9 +536,9 @@ let simplify_or p = let q2 = simpl_rec p2 in {p with pat_desc = Tpat_or (q1, q2, o)} with Var q2 -> raise (Var {p with pat_desc = Tpat_or (q1, q2, o)})) - | {pat_desc = Tpat_record (lbls, closed)} -> + | {pat_desc = Tpat_record (lbls, closed, rest)} -> let all_lbls = all_record_args lbls in - {p with pat_desc = Tpat_record (all_lbls, closed)} + {p with pat_desc = Tpat_record (all_lbls, closed, rest)} | _ -> p in try simpl_rec p with Var p -> p @@ -556,10 +556,12 @@ let simplify_cases args cls = | Tpat_any -> cl :: simplify rem | Tpat_alias (p, id, _) -> simplify ((p :: patl, bind Alias id arg action) :: rem) - | Tpat_record ([], _) -> (omega :: patl, action) :: simplify rem - | Tpat_record (lbls, closed) -> + | Tpat_record ([], _, _rest) -> (omega :: patl, action) :: simplify rem + | Tpat_record (lbls, closed, rest) -> let all_lbls = all_record_args lbls in - let full_pat = {pat with pat_desc = Tpat_record (all_lbls, closed)} in + let full_pat = + {pat with pat_desc = Tpat_record (all_lbls, closed, rest)} + in (full_pat :: patl, action) :: simplify rem | Tpat_or _ -> ( let pat_simple = simplify_or pat in @@ -615,7 +617,7 @@ let rec extract_vars r p = | Tpat_var (id, _) -> Ident_set.add id r | Tpat_alias (p, id, _) -> extract_vars (Ident_set.add id r) p | Tpat_tuple pats -> List.fold_left extract_vars r pats - | Tpat_record (lpats, _) -> + | Tpat_record (lpats, _, _rest) -> List.fold_left (fun r (_, _, p, _) -> extract_vars r p) r lpats | Tpat_construct (_, _, pats) -> List.fold_left extract_vars r pats | Tpat_array pats -> List.fold_left extract_vars r pats @@ -1422,7 +1424,7 @@ let record_matching_line num_fields lbl_pat_list = let get_args_record num_fields p rem = match p with | {pat_desc = Tpat_any} -> record_matching_line num_fields [] @ rem - | {pat_desc = Tpat_record (lbl_pat_list, _)} -> + | {pat_desc = Tpat_record (lbl_pat_list, _, _rest)} -> record_matching_line num_fields lbl_pat_list @ rem | _ -> assert false @@ -1430,8 +1432,8 @@ let matcher_record num_fields p rem = match p.pat_desc with | Tpat_or (_, _, _) -> raise OrPat | Tpat_any | Tpat_var _ -> record_matching_line num_fields [] @ rem - | Tpat_record ([], _) when num_fields = 0 -> rem - | Tpat_record (((_, lbl, _, _) :: _ as lbl_pat_list), _) + | Tpat_record ([], _, _rest) when num_fields = 0 -> rem + | Tpat_record (((_, lbl, _, _) :: _ as lbl_pat_list), _, _rest) when Array.length lbl.lbl_all = num_fields -> record_matching_line num_fields lbl_pat_list @ rem | _ -> raise NoMatch @@ -2561,7 +2563,7 @@ and do_compile_matching repr partial ctx arg pmh = compile_no_test (divide_tuple (List.length patl) (normalize_pat pat)) ctx_combine repr partial ctx pm - | Tpat_record ((_, lbl, _, _) :: _, _) -> + | Tpat_record ((_, lbl, _, _) :: _, _, _rest) -> compile_no_test (divide_record lbl.lbl_all (normalize_pat pat)) ctx_combine repr partial ctx pm @@ -2636,7 +2638,7 @@ let find_in_pat pred = | Tpat_alias (p, _, _) | Tpat_variant (_, Some p, _) -> find_rec p | Tpat_tuple ps | Tpat_construct (_, _, ps) | Tpat_array ps -> List.exists find_rec ps - | Tpat_record (lpats, _) -> + | Tpat_record (lpats, _, _rest) -> List.exists (fun (_, _, p, _) -> find_rec p) lpats | Tpat_or (p, q, _) -> find_rec p || find_rec q | Tpat_constant _ | Tpat_var _ | Tpat_any | Tpat_variant (_, None, _) -> @@ -2646,7 +2648,7 @@ let find_in_pat pred = let have_mutable_field p = match p with - | Tpat_record (lps, _) -> + | Tpat_record (lps, _, _rest) -> List.exists (fun (_, lbl, _, _) -> match lbl.Types.lbl_mut with @@ -2740,7 +2742,32 @@ let partial_function loc () = ], loc ) +(* For record patterns with rest, inject the rest binding into the action body *) +let inject_record_rest_binding param (pat, action) = + match pat.pat_desc with + | Tpat_record (_, _, Some rest) -> + let action_with_rest = + Llet + ( Strict, + Pgenval, + rest.rest_ident, + Lprim (Precord_spread_new rest.excluded_labels, [param], pat.pat_loc), + action ) + in + let pat_without_rest = + { + pat with + pat_desc = + (match pat.pat_desc with + | Tpat_record (fields, closed, _) -> Tpat_record (fields, closed, None) + | _ -> pat.pat_desc); + } + in + (pat_without_rest, action_with_rest) + | _ -> (pat, action) + let for_function loc repr param pat_act_list partial = + let pat_act_list = List.map (inject_record_rest_binding param) pat_act_list in compile_matching repr (partial_function loc) param pat_act_list partial (* In the following two cases, exhaustiveness info is not available! *) @@ -2809,6 +2836,28 @@ let for_let loc param pat body = | Tpat_var (id, _) -> (* fast path, and keep track of simple bindings to unboxable numbers *) Llet (Strict, Pgenval, id, param, body) + | Tpat_record (_, _, Some rest) -> + (* Record pattern with rest: compile the explicit field bindings normally, + then add a binding for the rest ident using Precord_spread_new *) + let body_with_rest = + Llet + ( Strict, + Pgenval, + rest.rest_ident, + Lprim (Precord_spread_new rest.excluded_labels, [param], loc), + body ) + in + (* Compile the explicit fields pattern (without rest) into the body *) + let pat_without_rest = + { + pat with + pat_desc = + (match pat.pat_desc with + | Tpat_record (fields, closed, _) -> Tpat_record (fields, closed, None) + | _ -> pat.pat_desc); + } + in + simple_for_let loc param pat_without_rest body_with_rest | _ -> simple_for_let loc param pat body (* Handling of tupled functions and matchings *) diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index 4ae23724fb4..047a71b2f0d 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -158,13 +158,13 @@ let all_coherent column = _ ) -> false) | Tpat_tuple l1, Tpat_tuple l2 -> List.length l1 = List.length l2 - | ( Tpat_record ((_, lbl1, _, _) :: _, _), - Tpat_record ((_, lbl2, _, _) :: _, _) ) -> + | ( Tpat_record ((_, lbl1, _, _) :: _, _, _), + Tpat_record ((_, lbl2, _, _) :: _, _, _) ) -> Array.length lbl1.lbl_all = Array.length lbl2.lbl_all | Tpat_any, _ | _, Tpat_any - | Tpat_record ([], _), Tpat_record (_, _) - | Tpat_record (_, _), Tpat_record ([], _) + | Tpat_record ([], _, _), Tpat_record (_, _, _) + | Tpat_record (_, _, _), Tpat_record ([], _, _) | Tpat_variant _, Tpat_variant _ | Tpat_array _, Tpat_array _ -> true @@ -301,7 +301,7 @@ module Compat = struct l1 = l2 && ocompat ~equal_cd op1 op2 | Tpat_constant c1, Tpat_constant c2 -> const_compare c1 c2 = 0 | Tpat_tuple ps, Tpat_tuple qs -> compats ~equal_cd ps qs - | Tpat_record (l1, _), Tpat_record (l2, _) -> + | Tpat_record (l1, _, _), Tpat_record (l2, _, _) -> let ps, qs = records_args l1 l2 in compats ~equal_cd ps qs | Tpat_array ps, Tpat_array qs -> @@ -399,7 +399,7 @@ let rec pretty_val ppf v = | _ -> fprintf ppf "@[<2>%s@ @[(%a)@]@]" name (pretty_vals ",") vs) | Tpat_variant (l, None, _) -> fprintf ppf "#%s" l | Tpat_variant (l, Some w, _) -> fprintf ppf "@[<2>#%s(%a)@]" l pretty_arg w - | Tpat_record (lvs, _) -> ( + | Tpat_record (lvs, _, _rest) -> ( let filtered_lvs = Ext_list.filter lvs (function | _, _, {pat_desc = Tpat_any}, _ -> false (* do not show lbl=_ *) @@ -496,7 +496,7 @@ let simple_match p1 p2 = let record_arg p = match p.pat_desc with | Tpat_any -> [] - | Tpat_record (args, _) -> args + | Tpat_record (args, _, _rest) -> args | _ -> fatal_error "Parmatch.as_record" (* Raise Not_found when pos is not present in arg *) @@ -569,14 +569,14 @@ let rec simple_match_args p1 p2 = | Tpat_construct (_, _, args) -> args | Tpat_variant (_, Some arg, _) -> [arg] | Tpat_tuple args -> args - | Tpat_record (args, _) -> extract_fields (record_arg p1) args + | Tpat_record (args, _, _rest) -> extract_fields (record_arg p1) args | Tpat_array args -> args | Tpat_any | Tpat_var _ -> ( match p1.pat_desc with | Tpat_construct (_, _, args) -> omega_list args | Tpat_variant (_, Some _, _) -> [omega] | Tpat_tuple args -> omega_list args - | Tpat_record (args, _) -> omega_list args + | Tpat_record (args, _, _rest) -> omega_list args | Tpat_array args -> omega_list args | _ -> []) | _ -> [] @@ -601,11 +601,12 @@ let rec normalize_pat q = q.pat_type q.pat_env | Tpat_array args -> make_pat (Tpat_array (omega_list args)) q.pat_type q.pat_env - | Tpat_record (largs, closed) -> + | Tpat_record (largs, closed, rest) -> make_pat (Tpat_record ( List.map (fun (lid, lbl, _, opt) -> (lid, lbl, omega, opt)) largs, - closed )) + closed, + rest )) q.pat_type q.pat_env | Tpat_or _ -> fatal_error "Parmatch.normalize_pat" @@ -623,7 +624,7 @@ let discr_pat q pss = acc_pat acc ((p1 :: ps) :: (p2 :: ps) :: pss) | ({pat_desc = Tpat_any | Tpat_var _} :: _) :: pss -> acc_pat acc pss | (({pat_desc = Tpat_tuple _} as p) :: _) :: _ -> normalize_pat p - | (({pat_desc = Tpat_record (largs, closed)} as p) :: _) :: pss -> + | (({pat_desc = Tpat_record (largs, closed, rest)} as p) :: _) :: pss -> let new_omegas = List.fold_right (fun (lid, lbl, _, opt) r -> @@ -634,7 +635,7 @@ let discr_pat q pss = largs (record_arg acc) in acc_pat - (make_pat (Tpat_record (new_omegas, closed)) p.pat_type p.pat_env) + (make_pat (Tpat_record (new_omegas, closed, rest)) p.pat_type p.pat_env) pss | _ -> acc in @@ -661,7 +662,7 @@ let do_set_args erase_mutable q r = | {pat_desc = Tpat_tuple omegas} -> let args, rest = read_args omegas r in make_pat (Tpat_tuple args) q.pat_type q.pat_env :: rest - | {pat_desc = Tpat_record (omegas, closed)} -> + | {pat_desc = Tpat_record (omegas, closed, pat_rest)} -> let args, rest = read_args omegas r in make_pat (Tpat_record @@ -676,7 +677,8 @@ let do_set_args erase_mutable q r = then (lid, lbl, omega, opt) else (lid, lbl, arg, opt)) omegas args, - closed )) + closed, + pat_rest )) q.pat_type q.pat_env :: rest | {pat_desc = Tpat_construct (lid, c, omegas)} -> @@ -967,7 +969,7 @@ let pats_of_type ?(always = false) env ty = (mknoloc (Longident.Lident "?pat_of_label?"), ld, omega, false)) labels in - [make_pat (Tpat_record (fields, Closed)) ty env] + [make_pat (Tpat_record (fields, Closed, None)) ty env] | _ -> [omega] with Not_found -> [omega]) | Ttuple tl -> [make_pat (Tpat_tuple (omegas (List.length tl))) ty env] @@ -1170,7 +1172,8 @@ let rec has_instance p = | Tpat_or (p1, p2, _) -> has_instance p1 || has_instance p2 | Tpat_construct (_, _, ps) | Tpat_tuple ps | Tpat_array ps -> has_instances ps - | Tpat_record (lps, _) -> has_instances (List.map (fun (_, _, x, _) -> x) lps) + | Tpat_record (lps, _, _rest) -> + has_instances (List.map (fun (_, _, x, _) -> x) lps) and has_instances = function | [] -> true @@ -1379,7 +1382,7 @@ let print_pat pat = | Tpat_tuple list -> Printf.sprintf "(%s)" (String.concat "," (List.map string_of_pat list)) | Tpat_variant (_, _, _) -> "variant" - | Tpat_record (_, _) -> "record" + | Tpat_record (_, _, _) -> "record" | Tpat_array _ -> "array" in Printf.fprintf stderr "PAT[%s]\n%!" (string_of_pat pat) @@ -1784,7 +1787,7 @@ let rec le_pat p q = | Tpat_variant (l1, None, _r1), Tpat_variant (l2, None, _) -> l1 = l2 | Tpat_variant (_, _, _), Tpat_variant (_, _, _) -> false | Tpat_tuple ps, Tpat_tuple qs -> le_pats ps qs - | Tpat_record (l1, _), Tpat_record (l2, _) -> + | Tpat_record (l1, _, _), Tpat_record (l2, _, _) -> let ps, qs = records_args l1 l2 in le_pats ps qs | Tpat_array ps, Tpat_array qs -> Ext_list.same_length ps qs && le_pats ps qs @@ -1831,9 +1834,9 @@ let rec lub p q = let r = lub p1 p2 in make_pat (Tpat_variant (l1, Some r, row)) p.pat_type p.pat_env | Tpat_variant (l1, None, _row), Tpat_variant (l2, None, _) when l1 = l2 -> p - | Tpat_record (l1, closed), Tpat_record (l2, _) -> + | Tpat_record (l1, closed, rest), Tpat_record (l2, _, _) -> let rs = record_lubs l1 l2 in - make_pat (Tpat_record (rs, closed)) p.pat_type p.pat_env + make_pat (Tpat_record (rs, closed, rest)) p.pat_type p.pat_env | Tpat_array ps, Tpat_array qs when List.length ps = List.length qs -> let rs = lubs ps qs in make_pat (Tpat_array rs) p.pat_type p.pat_env @@ -1992,7 +1995,7 @@ module Conv = struct | Tpat_variant (label, p_opt, _row_desc) -> let arg = Misc.may_map loop p_opt in mkpat (Ppat_variant (label, arg)) - | Tpat_record (subpatterns, _closed_flag) -> + | Tpat_record (subpatterns, _closed_flag, _rest) -> let fields = List.map (fun (_, lbl, p, optional) -> @@ -2001,7 +2004,7 @@ module Conv = struct {lid = mknoloc (Longident.Lident id); x = loop p; opt = optional}) subpatterns in - mkpat (Ppat_record (fields, Open)) + mkpat (Ppat_record (fields, Open, None)) | Tpat_array lst -> mkpat (Ppat_array (List.map loop lst)) in let ps = loop typed in @@ -2153,7 +2156,7 @@ let rec collect_paths_from_pat r p = | Tpat_array ps | Tpat_construct (_, {cstr_tag = Cstr_extension _}, ps) -> List.fold_left collect_paths_from_pat r ps - | Tpat_record (lps, _) -> + | Tpat_record (lps, _, _rest) -> List.fold_left (fun r (_, _, p, _) -> collect_paths_from_pat r p) r lps | Tpat_variant (_, Some p, _) | Tpat_alias (p, _, _) -> collect_paths_from_pat r p @@ -2284,7 +2287,7 @@ let inactive ~partial pat = | Tpat_tuple ps | Tpat_construct (_, _, ps) -> List.for_all (fun p -> loop p) ps | Tpat_alias (p, _, _) | Tpat_variant (_, Some p, _) -> loop p - | Tpat_record (ldps, _) -> + | Tpat_record (ldps, _, _rest) -> List.for_all (fun (_, lbl, p, _) -> lbl.lbl_mut = Immutable && loop p) ldps @@ -2432,12 +2435,12 @@ let filter_all = a pattern *) let discr_head pat = match pat.pat_desc with - | Tpat_record (lbls, closed) -> + | Tpat_record (lbls, closed, rest) -> (* a partial record pattern { f1 = p1; f2 = p2; _ } needs to be expanded, otherwise matching against this head would drop the pattern arguments for non-mentioned fields *) let lbls = all_record_args lbls in - normalize_pat {pat with pat_desc = Tpat_record (lbls, closed)} + normalize_pat {pat with pat_desc = Tpat_record (lbls, closed, rest)} | _ -> normalize_pat pat in diff --git a/compiler/ml/parsetree.ml b/compiler/ml/parsetree.ml index 29207d0150b..fc4709b4efb 100644 --- a/compiler/ml/parsetree.ml +++ b/compiler/ml/parsetree.ml @@ -184,9 +184,10 @@ and pattern_desc = (* `A (None) `A P (Some P) *) - | Ppat_record of pattern record_element list * closed_flag - (* { l1=P1; ...; ln=Pn } (flag = Closed) - { l1=P1; ...; ln=Pn; _} (flag = Open) + | Ppat_record of pattern record_element list * closed_flag * pattern option + (* { l1=P1; ...; ln=Pn } (flag = Closed, rest = None) + { l1=P1; ...; ln=Pn; _} (flag = Open, rest = None) + { l1=P1; ...; ...T as r } (rest = Some pattern) Invariant: n > 0 *) diff --git a/compiler/ml/pprintast.ml b/compiler/ml/pprintast.ml index 10025b0e0e7..b079c5579ca 100644 --- a/compiler/ml/pprintast.ml +++ b/compiler/ml/pprintast.ml @@ -460,7 +460,7 @@ and simple_pattern ctxt (f : Format.formatter) (x : pattern) : unit = | Ppat_array l -> pp f "@[<2>[|%a|]@]" (list (pattern1 ctxt) ~sep:";") l | Ppat_unpack s -> pp f "(module@ %s)@ " s.txt | Ppat_type li -> pp f "#%a" longident_loc li - | Ppat_record (l, closed) -> ( + | Ppat_record (l, closed, _rest) -> ( let longident_x_pattern f {lid = li; x = p; opt} = let opt_str = if opt then "?" else "" in match (li, p) with diff --git a/compiler/ml/printast.ml b/compiler/ml/printast.ml index 5aae8263738..3f4cad224a3 100644 --- a/compiler/ml/printast.ml +++ b/compiler/ml/printast.ml @@ -205,7 +205,7 @@ and pattern i ppf x = | Ppat_variant (l, po) -> line i ppf "Ppat_variant \"%s\"\n" l; option i pattern ppf po - | Ppat_record (l, c) -> + | Ppat_record (l, c, _rest) -> line i ppf "Ppat_record %a\n" fmt_closed_flag c; list i longident_x_pattern ppf l | Ppat_array l -> diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index e30f3c867f2..aac5010d326 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -116,6 +116,8 @@ let primitive ppf = function | Pfield (n, fld) -> fprintf ppf "field:%s/%i" (str_of_field_info fld) n | Psetfield (n, _) -> fprintf ppf "setfield %i" n | Pduprecord -> fprintf ppf "duprecord" + | Precord_spread_new excluded -> + fprintf ppf "record_spread_new(%s)" (String.concat ", " excluded) | Pccall p -> fprintf ppf "%s" p.prim_name | Praise k -> fprintf ppf "%s" (Lambda.raise_kind k) | Pobjcomp Ceq -> fprintf ppf "==" diff --git a/compiler/ml/printtyped.ml b/compiler/ml/printtyped.ml index f8bfaa170f2..57a56b052a7 100644 --- a/compiler/ml/printtyped.ml +++ b/compiler/ml/printtyped.ml @@ -231,7 +231,7 @@ and pattern i ppf x = | Tpat_variant (l, po, _) -> line i ppf "Tpat_variant \"%s\"\n" l; option i pattern ppf po - | Tpat_record (l, _c) -> + | Tpat_record (l, _c, _rest) -> line i ppf "Tpat_record\n"; list i longident_x_pattern ppf l | Tpat_array l -> diff --git a/compiler/ml/rec_check.ml b/compiler/ml/rec_check.ml index 61f55114e97..bd3cddf1b1e 100644 --- a/compiler/ml/rec_check.ml +++ b/compiler/ml/rec_check.ml @@ -156,7 +156,7 @@ let rec pattern_variables : Typedtree.pattern -> Ident.t list = | Tpat_construct (_, _, pats) -> List.concat (List.map pattern_variables pats) | Tpat_variant (_, Some pat, _) -> pattern_variables pat | Tpat_variant (_, None, _) -> [] - | Tpat_record (fields, _) -> + | Tpat_record (fields, _, _rest) -> List.concat (List.map (fun (_, _, p, _) -> pattern_variables p) fields) | Tpat_array pats -> List.concat (List.map pattern_variables pats) | Tpat_or (l, r, _) -> pattern_variables l @ pattern_variables r @@ -438,7 +438,7 @@ and is_destructuring_pattern : Typedtree.pattern -> bool = | Tpat_tuple _ -> true | Tpat_construct (_, _, _) -> true | Tpat_variant _ -> true - | Tpat_record (_, _) -> true + | Tpat_record (_, _, _) -> true | Tpat_array _ -> true | Tpat_or (l, r, _) -> is_destructuring_pattern l || is_destructuring_pattern r diff --git a/compiler/ml/tast_iterator.ml b/compiler/ml/tast_iterator.ml index 86f77420bd2..077837d2af6 100644 --- a/compiler/ml/tast_iterator.ml +++ b/compiler/ml/tast_iterator.ml @@ -129,7 +129,7 @@ let pat sub {pat_extra; pat_desc; pat_env; _} = | Tpat_tuple l -> List.iter (sub.pat sub) l | Tpat_construct (_, _, l) -> List.iter (sub.pat sub) l | Tpat_variant (_, po, _) -> Option.iter (sub.pat sub) po - | Tpat_record (l, _) -> List.iter (fun (_, _, i, _) -> sub.pat sub i) l + | Tpat_record (l, _, _rest) -> List.iter (fun (_, _, i, _) -> sub.pat sub i) l | Tpat_array l -> List.iter (sub.pat sub) l | Tpat_or (p1, p2, _) -> sub.pat sub p1; diff --git a/compiler/ml/tast_mapper.ml b/compiler/ml/tast_mapper.ml index 1d0e49efd35..fd2e57baee5 100644 --- a/compiler/ml/tast_mapper.ml +++ b/compiler/ml/tast_mapper.ml @@ -171,8 +171,8 @@ let pat sub x = | Tpat_construct (loc, cd, l) -> Tpat_construct (loc, cd, List.map (sub.pat sub) l) | Tpat_variant (l, po, rd) -> Tpat_variant (l, opt (sub.pat sub) po, rd) - | Tpat_record (l, closed) -> - Tpat_record (List.map (tuple4 id id (sub.pat sub) id) l, closed) + | Tpat_record (l, closed, rest) -> + Tpat_record (List.map (tuple4 id id (sub.pat sub) id) l, closed, rest) | Tpat_array l -> Tpat_array (List.map (sub.pat sub) l) | Tpat_or (p1, p2, rd) -> Tpat_or (sub.pat sub p1, sub.pat sub p2, rd) | Tpat_alias (p, id, s) -> Tpat_alias (sub.pat sub p, id, s) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 37bbf81b60a..47f4e6b8753 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -96,6 +96,12 @@ type error = | Field_access_on_dict_type | Jsx_not_enabled | Tagged_template_non_tag of type_expr + | Record_rest_invalid_type + | Record_rest_requires_type_annotation of string + | Record_rest_not_record of Longident.t + | Record_rest_field_not_optional of string * Longident.t + | Record_rest_field_missing of string * Longident.t + | Record_rest_extra_field of string * Longident.t exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -512,7 +518,7 @@ let rec build_as_type env p = row_fixed = false; row_closed = false; }) - | Tpat_record (lpl, _) -> + | Tpat_record (lpl, _, _rest) -> let lbl = snd4 (List.hd lpl) in if lbl.lbl_private = Private then p.pat_type else @@ -1494,7 +1500,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp match (sarg, arg_type) with | Some p, [ty] -> type_pat p ty (fun p -> k (Some p)) | _ -> k None) - | Ppat_record (lid_sp_list, closed) -> + | Ppat_record (lid_sp_list, closed, rest) -> let has_dict_pattern_attr = Dict_type_helpers.has_dict_pattern_attribute sp.ppat_attributes in @@ -1550,12 +1556,146 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp k (label_lid, label, arg, opt)) in let k' k lbl_pat_list = + (* When there's a rest pattern, use Open to suppress missing-field warnings *) + let effective_closed = + match rest with + | Some _ -> Asttypes.Open + | None -> closed + in check_recordpat_labels ~get_jsx_component_error_info loc lbl_pat_list - closed; + effective_closed; unify_pat_types loc !env record_ty expected_ty; + (* Resolve the rest pattern info *) + let typed_rest = + match rest with + | None -> None + | Some rest_pat -> + (* Extract type annotation and binding name from rest pattern *) + let rest_type_lid, rest_name = + match rest_pat.ppat_desc with + | Ppat_constraint ({ppat_desc = Ppat_var name}, cty) -> ( + match cty.ptyp_desc with + | Ptyp_constr (lid, []) -> (lid, name) + | _ -> + raise + (Error (rest_pat.ppat_loc, !env, Record_rest_invalid_type))) + | Ppat_var name -> + (* No type annotation — try to infer from context *) + (* For now, require type annotation *) + raise + (Error + ( rest_pat.ppat_loc, + !env, + Record_rest_requires_type_annotation name.txt )) + | _ -> + raise (Error (rest_pat.ppat_loc, !env, Record_rest_invalid_type)) + in + (* Look up the rest record type *) + let rest_path, rest_decl = + Typetexp.find_type !env rest_type_lid.loc rest_type_lid.txt + in + let rest_labels = + match rest_decl with + | {type_kind = Type_record (labels, _)} -> labels + | _ -> + raise + (Error + ( rest_type_lid.loc, + !env, + Record_rest_not_record rest_type_lid.txt )) + in + (* Get explicit field names *) + let explicit_fields = + List.map (fun (_, label, _, _) -> label.lbl_name) lbl_pat_list + in + (* Get explicit optional fields *) + let explicit_optional_fields = + List.filter_map + (fun (_, label, _, opt) -> + if opt then Some label.lbl_name else None) + lbl_pat_list + in + (* Get rest field names *) + let rest_field_names = + List.map + (fun (l : Types.label_declaration) -> Ident.name l.ld_id) + rest_labels + in + (* Validate: fields in both explicit and rest must be optional in the explicit pattern *) + List.iter + (fun rest_field -> + if + List.mem rest_field explicit_fields + && not (List.mem rest_field explicit_optional_fields) + then + raise + (Error + ( rest_pat.ppat_loc, + !env, + Record_rest_field_not_optional + (rest_field, rest_type_lid.txt) ))) + rest_field_names; + (* Validate: all source fields must be in explicit or rest *) + (match lbl_pat_list with + | (_, label1, _, _) :: _ -> + let all_source = label1.lbl_all in + Array.iter + (fun source_label -> + let name = source_label.lbl_name in + if + (not (List.mem name explicit_fields)) + && not (List.mem name rest_field_names) + then + raise + (Error + ( rest_pat.ppat_loc, + !env, + Record_rest_field_missing (name, rest_type_lid.txt) ))) + all_source + | [] -> ()); + (* Validate: rest type fields must all exist in source *) + (match lbl_pat_list with + | (_, label1, _, _) :: _ -> + let all_source = label1.lbl_all in + let source_field_names = + Array.to_list (Array.map (fun l -> l.lbl_name) all_source) + in + List.iter + (fun (rest_label : Types.label_declaration) -> + if + not + (List.mem (Ident.name rest_label.ld_id) source_field_names) + then + raise + (Error + ( rest_type_lid.loc, + !env, + Record_rest_extra_field + (Ident.name rest_label.ld_id, rest_type_lid.txt) ))) + rest_labels + | [] -> ()); + let rest_type_expr = + newgenty + (Tconstr + ( rest_path, + List.map (fun _ -> newvar ()) rest_decl.type_params, + ref Mnil )) + in + let rest_ident = + enter_variable rest_pat.ppat_loc rest_name rest_type_expr + in + Some + { + Typedtree.rest_ident; + rest_type = rest_type_expr; + rest_path; + rest_labels; + excluded_labels = explicit_fields; + } + in rp k { - pat_desc = Tpat_record (lbl_pat_list, closed); + pat_desc = Tpat_record (lbl_pat_list, closed, typed_rest); pat_loc = loc; pat_extra = []; pat_type = expected_ty; @@ -2121,7 +2261,7 @@ let iter_ppat f p = | Ppat_open (_, p) | Ppat_constraint (p, _) -> f p - | Ppat_record (args, _flag) -> List.iter (fun {x = p} -> f p) args + | Ppat_record (args, _flag, _rest) -> List.iter (fun {x = p} -> f p) args let contains_polymorphic_variant p = let rec loop p = @@ -5072,8 +5212,34 @@ let report_error env loc ppf error = with @{taggedTemplate<...>@} instead of using the removed \ @{@@taggedTemplate@} decorator.@,\ \ - To use a ReScript function as a tag, lift it with \ - @{TaggedTemplate.make@}.@]" + @{TaggedTemplate.make@}.@]" type_expr typ + | Record_rest_invalid_type -> + fprintf ppf "Record rest pattern must have the form: ...Type.t as name" + | Record_rest_requires_type_annotation name -> + fprintf ppf + "Record rest pattern `...%s` requires a type annotation. Use `...Type.t \ + as %s`." + name name + | Record_rest_not_record lid -> + fprintf ppf + "Type %a is not a record type and cannot be used as a record rest \ + pattern." + longident lid + | Record_rest_field_not_optional (field, lid) -> + fprintf ppf + "Field `%s` appears in both the explicit pattern and the rest type `%a`. \ + It must be marked as optional (`?%s`) in the explicit pattern." + field longident lid field + | Record_rest_field_missing (field, lid) -> + fprintf ppf + "Field `%s` is not covered by the explicit pattern or the rest type `%a`." + field longident lid + | Record_rest_extra_field (field, lid) -> + fprintf ppf + "Field `%s` in the rest type `%a` does not exist in the source record \ + type." + field longident lid let report_error env loc ppf err = Printtyp.wrap_printing_env env (fun () -> report_error env loc ppf err) diff --git a/compiler/ml/typecore.mli b/compiler/ml/typecore.mli index cba37060eb6..13129276c10 100644 --- a/compiler/ml/typecore.mli +++ b/compiler/ml/typecore.mli @@ -129,6 +129,12 @@ type error = | Field_access_on_dict_type | Jsx_not_enabled | Tagged_template_non_tag of type_expr + | Record_rest_invalid_type + | Record_rest_requires_type_annotation of string + | Record_rest_not_record of Longident.t + | Record_rest_field_not_optional of string * Longident.t + | Record_rest_field_missing of string * Longident.t + | Record_rest_extra_field of string * Longident.t exception Error of Location.t * Env.t * error exception Error_forward of Location.error diff --git a/compiler/ml/typedtree.ml b/compiler/ml/typedtree.ml index f772a0eb64b..cbabf20ffd7 100644 --- a/compiler/ml/typedtree.ml +++ b/compiler/ml/typedtree.ml @@ -35,6 +35,14 @@ type pattern = { pat_attributes: attribute list; } +and record_pat_rest = { + rest_ident: Ident.t; + rest_type: type_expr; + rest_path: Path.t; + rest_labels: Types.label_declaration list; + excluded_labels: string list; +} + and pat_extra = | Tpat_constraint of core_type | Tpat_type of Path.t * Longident.t loc @@ -52,6 +60,7 @@ and pattern_desc = | Tpat_record of (Longident.t loc * label_description * pattern * bool (* optional *)) list * closed_flag + * record_pat_rest option | Tpat_array of pattern list | Tpat_or of pattern * pattern * row_desc option @@ -417,7 +426,7 @@ let iter_pattern_desc f = function | Tpat_tuple patl -> List.iter f patl | Tpat_construct (_, _, patl) -> List.iter f patl | Tpat_variant (_, pat, _) -> may f pat - | Tpat_record (lbl_pat_list, _) -> + | Tpat_record (lbl_pat_list, _, _rest) -> List.iter (fun (_, _, pat, _) -> f pat) lbl_pat_list | Tpat_array patl -> List.iter f patl | Tpat_or (p1, p2, _) -> @@ -429,8 +438,9 @@ let map_pattern_desc f d = match d with | Tpat_alias (p1, id, s) -> Tpat_alias (f p1, id, s) | Tpat_tuple pats -> Tpat_tuple (List.map f pats) - | Tpat_record (lpats, closed) -> - Tpat_record (List.map (fun (lid, l, p, o) -> (lid, l, f p, o)) lpats, closed) + | Tpat_record (lpats, closed, rest) -> + Tpat_record + (List.map (fun (lid, l, p, o) -> (lid, l, f p, o)) lpats, closed, rest) | Tpat_construct (lid, c, pats) -> Tpat_construct (lid, c, List.map f pats) | Tpat_array pats -> Tpat_array (List.map f pats) | Tpat_variant (x1, Some p1, x2) -> Tpat_variant (x1, Some (f p1), x2) @@ -450,6 +460,13 @@ let rec bound_idents pat = | Tpat_or (p1, _, _) -> (* Invariant : both arguments binds the same variables *) bound_idents p1 + | Tpat_record (_, _, Some rest) -> + (* Rest ident is added via enter_variable during type checking, + but we also need it in bound_idents for Lambda compilation *) + idents := + (rest.rest_ident, Location.mknoloc (Ident.name rest.rest_ident)) + :: !idents; + iter_pattern_desc bound_idents pat.pat_desc | d -> iter_pattern_desc bound_idents d let pat_bound_idents pat = diff --git a/compiler/ml/typedtree.mli b/compiler/ml/typedtree.mli index 538405a7691..3dbeb96d7f3 100644 --- a/compiler/ml/typedtree.mli +++ b/compiler/ml/typedtree.mli @@ -43,6 +43,14 @@ type pattern = { pat_attributes: attributes; } +and record_pat_rest = { + rest_ident: Ident.t; + rest_type: type_expr; + rest_path: Path.t; + rest_labels: Types.label_declaration list; + excluded_labels: string list; +} + and pat_extra = | Tpat_constraint of core_type (** P : T { pat_desc = P @@ -85,6 +93,7 @@ and pattern_desc = | Tpat_record of (Longident.t loc * label_description * pattern * bool (* optional *)) list * closed_flag + * record_pat_rest option (** { l1=P1; ...; ln=Pn } (flag = Closed) { l1=P1; ...; ln=Pn; _} (flag = Open) diff --git a/compiler/ml/typedtree_iter.ml b/compiler/ml/typedtree_iter.ml index 6f48bcd620a..a177d6aed7e 100644 --- a/compiler/ml/typedtree_iter.ml +++ b/compiler/ml/typedtree_iter.ml @@ -196,7 +196,7 @@ end = struct match pato with | None -> () | Some pat -> iter_pattern pat) - | Tpat_record (list, _closed) -> + | Tpat_record (list, _closed, _rest) -> List.iter (fun (_, _, pat, _) -> iter_pattern pat) list | Tpat_array list -> List.iter iter_pattern list | Tpat_or (p1, p2, _) -> diff --git a/compiler/syntax/src/res_ast_debugger.ml b/compiler/syntax/src/res_ast_debugger.ml index 6749355ea3e..0436254c07a 100644 --- a/compiler/syntax/src/res_ast_debugger.ml +++ b/compiler/syntax/src/res_ast_debugger.ml @@ -804,7 +804,7 @@ module Sexp_ast = struct | None -> Sexp.atom "None" | Some p -> Sexp.list [Sexp.atom "Some"; pattern p]); ] - | Ppat_record (rows, flag) -> + | Ppat_record (rows, flag, _rest) -> Sexp.list [ Sexp.atom "Ppat_record"; diff --git a/compiler/syntax/src/res_comments_table.ml b/compiler/syntax/src/res_comments_table.ml index 9741d3ece62..aef9ee4959a 100644 --- a/compiler/syntax/src/res_comments_table.ml +++ b/compiler/syntax/src/res_comments_table.ml @@ -2135,7 +2135,7 @@ and walk_pattern pat t comments = | Ppat_variant (_label, None) -> () | Ppat_variant (_label, Some pat) -> walk_pattern pat t comments | Ppat_type _ -> () - | Ppat_record (record_rows, _) -> + | Ppat_record (record_rows, _, _rest) -> walk_list (Ext_list.map record_rows (fun {lid; x = p} -> PatternRecordRow (lid, p))) t comments diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index 2d3eabd3944..05e5f157e10 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -336,6 +336,7 @@ type fundef_parameter = type record_pattern_item = | PatUnderscore | PatField of Parsetree.pattern Parsetree.record_element + | PatRest of Parsetree.pattern type context = OrdinaryExpr | TernaryTrueBranchExpr | WhenExpr @@ -1517,9 +1518,71 @@ and parse_record_pattern_row_field ~attrs p = and parse_record_pattern_row p = let attrs = parse_attributes p in match p.Parser.token with - | DotDotDot -> + | DotDotDot -> ( Parser.next p; - Some (true, PatField (parse_record_pattern_row_field ~attrs p)) + let start_pos = p.Parser.start_pos in + match p.Parser.token with + | Uident _ -> + (* ...ModulePath.t as name *) + let type_path = parse_value_path p in + let type_loc = type_path.loc in + let core_type = Ast_helper.Typ.constr ~loc:type_loc type_path [] in + Parser.expect As p; + let name_start = p.start_pos in + let name = + match p.token with + | Lident ident -> + Parser.next p; + Location.mkloc ident (mk_loc name_start p.prev_end_pos) + | _ -> + Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); + Location.mkloc "_" (mk_loc name_start p.prev_end_pos) + in + let rest_loc = mk_loc start_pos p.prev_end_pos in + let rest_pat = + Ast_helper.Pat.constraint_ ~loc:rest_loc ~attrs + (Ast_helper.Pat.var ~loc:name.loc name) + core_type + in + Some (false, PatRest rest_pat) + | Lident ident -> + Parser.next p; + if p.Parser.token = As then ( + (* ...typeName as name *) + let type_path = + Location.mkloc (Longident.Lident ident) + (mk_loc start_pos p.prev_end_pos) + in + let type_loc = type_path.loc in + let core_type = Ast_helper.Typ.constr ~loc:type_loc type_path [] in + Parser.expect As p; + let name_start = p.start_pos in + let name = + match p.token with + | Lident id -> + Parser.next p; + Location.mkloc id (mk_loc name_start p.prev_end_pos) + | _ -> + Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); + Location.mkloc "_" (mk_loc name_start p.prev_end_pos) + in + let rest_loc = mk_loc start_pos p.prev_end_pos in + let rest_pat = + Ast_helper.Pat.constraint_ ~loc:rest_loc ~attrs + (Ast_helper.Pat.var ~loc:name.loc name) + core_type + in + Some (false, PatRest rest_pat)) + else + (* ...name (no type annotation) *) + let loc = mk_loc start_pos p.prev_end_pos in + let rest_pat = + Ast_helper.Pat.var ~loc ~attrs (Location.mkloc ident loc) + in + Some (false, PatRest rest_pat) + | _ -> + (* Fallback: treat as old-style spread (error) *) + Some (true, PatField (parse_record_pattern_row_field ~attrs p))) | Uident _ | Lident _ -> Some (false, PatField (parse_record_pattern_row_field ~attrs p)) | Question -> ( @@ -1560,14 +1623,14 @@ and parse_record_pattern ~attrs p = ~f:parse_record_pattern_row in Parser.expect Rbrace p; - let fields, closed_flag = + let fields, closed_flag, rest = let raw_fields, flag = match raw_fields with | (_hasSpread, PatUnderscore) :: rest -> (rest, Asttypes.Open) | raw_fields -> (raw_fields, Asttypes.Closed) in List.fold_left - (fun (fields, flag) curr -> + (fun (fields, flag, rest) curr -> let has_spread, field = curr in match field with | PatField field -> @@ -1575,12 +1638,13 @@ and parse_record_pattern ~attrs p = let pattern = field.x in Parser.err ~start_pos:pattern.Parsetree.ppat_loc.loc_start p (Diagnostics.message Error_messages.record_pattern_spread)); - (field :: fields, flag) - | PatUnderscore -> (fields, flag)) - ([], flag) raw_fields + (field :: fields, flag, rest) + | PatRest rest_pat -> (fields, flag, Some rest_pat) + | PatUnderscore -> (fields, flag, rest)) + ([], flag, None) raw_fields in let loc = mk_loc start_pos p.prev_end_pos in - Ast_helper.Pat.record ~loc ~attrs fields closed_flag + Ast_helper.Pat.record ~loc ~attrs ?rest fields closed_flag and parse_tuple_pattern ~attrs ~first ~start_pos p = let patterns = diff --git a/compiler/syntax/src/res_printer.ml b/compiler/syntax/src/res_printer.ml index 6c47f99bfb2..857404064e5 100644 --- a/compiler/syntax/src/res_printer.ml +++ b/compiler/syntax/src/res_printer.ml @@ -2785,7 +2785,7 @@ and print_pattern ~state (p : Parsetree.pattern) cmt_tbl = Doc.concat [Doc.text "..."; print_ident_path ident cmt_tbl] | Ppat_type ident -> Doc.concat [Doc.text "#..."; print_ident_path ident cmt_tbl] - | Ppat_record (rows, _) + | Ppat_record (rows, _, _rest) when Parsetree_viewer.has_dict_pattern_attribute p.ppat_attributes -> Doc.concat [ @@ -2803,9 +2803,23 @@ and print_pattern ~state (p : Parsetree.pattern) cmt_tbl = Doc.soft_line; Doc.rbrace; ] - | Ppat_record ([], Open) -> + | Ppat_record ([], Open, None) -> Doc.concat [Doc.lbrace; Doc.text "_"; Doc.rbrace] - | Ppat_record (rows, open_flag) -> + | Ppat_record (rows, open_flag, rest) -> + let print_rest_pattern rest_pat = + match rest_pat.Parsetree.ppat_desc with + | Ppat_constraint ({ppat_desc = Ppat_var name}, typ) -> + Doc.concat + [ + Doc.text "..."; + print_typ_expr ~state typ cmt_tbl; + Doc.text " as "; + Doc.text name.txt; + ] + | Ppat_var name -> Doc.concat [Doc.text "..."; Doc.text name.txt] + | _ -> + Doc.concat [Doc.text "..."; print_pattern ~state rest_pat cmt_tbl] + in Doc.group (Doc.concat [ @@ -2820,9 +2834,19 @@ and print_pattern ~state (p : Parsetree.pattern) cmt_tbl = (fun row -> print_pattern_record_row ~state row cmt_tbl) rows); - (match open_flag with - | Open -> Doc.concat [Doc.text ","; Doc.line; Doc.text "_"] - | Closed -> Doc.nil); + (match rest with + | Some rest_pat -> + Doc.concat + [ + (if rows <> [] then Doc.concat [Doc.text ","; Doc.line] + else Doc.nil); + print_rest_pattern rest_pat; + ] + | None -> ( + match open_flag with + | Open -> + Doc.concat [Doc.text ","; Doc.line; Doc.text "_"] + | Closed -> Doc.nil)); ]); Doc.if_breaks (Doc.text ",") Doc.nil; Doc.soft_line; diff --git a/tests/syntax_tests/data/parsing/errors/other/expected/spread.res.txt b/tests/syntax_tests/data/parsing/errors/other/expected/spread.res.txt index 2b33d97dbce..9384f6d2ff3 100644 --- a/tests/syntax_tests/data/parsing/errors/other/expected/spread.res.txt +++ b/tests/syntax_tests/data/parsing/errors/other/expected/spread.res.txt @@ -28,20 +28,6 @@ Possible solutions: Explanation: since records have a known, fixed shape, a spread like `{a, ...b}` wouldn't make sense, as `b` would override every field of `a` anyway. - Syntax error! - syntax_tests/data/parsing/errors/other/spread.res:4:15-18 - - 2 │ - 3 │ let record = {...x, ...y} - 4 │ let {...x, ...y} = myRecord - 5 │ - 6 │ let list{...x, ...y} = myList - - Record spread (`...`) is not supported in pattern matches. -Explanation: you can't collect a subset of a record's field into its own record, since a record needs an explicit declaration and that subset wouldn't have one. -Solution: you need to pull out each field you want explicitly. - - Syntax error! syntax_tests/data/parsing/errors/other/spread.res:6:13-22 @@ -56,7 +42,7 @@ Explanation: a list spread at the tail is efficient, but a spread in the middle let [|arr;_|] = [|1;2;3|] let record = { x with y } -let { x; y } = myRecord +let { } = myRecord let x::y = myList type nonrec t = { ...: a } diff --git a/tests/syntax_tests/data/parsing/grammar/pattern/expected/record.res.txt b/tests/syntax_tests/data/parsing/grammar/pattern/expected/record.res.txt index 8560cd48a21..b1f54e398fb 100644 --- a/tests/syntax_tests/data/parsing/grammar/pattern/expected/record.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/pattern/expected/record.res.txt @@ -80,4 +80,12 @@ let f [arity:1](({ a } : myRecord) as p) = () ;;for { a;_} = 0 to 10 do () done ;;for { a;_} = 0 to 10 do () done ;;for { a;_} = 0 to 10 do () done -;;for ({ a } : myRecord) = 0 to 10 do () done \ No newline at end of file +;;for ({ a } : myRecord) = 0 to 10 do () done +let { a } = x +let { a } = x +let { a } = x +let { a; b } = x +;;match x with | { a } -> () | { a } -> () | { a } -> () +let f [arity:1]{ a } = () +let f [arity:1]{ a } = () +let f [arity:1]{ a } = () \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/pattern/record.res b/tests/syntax_tests/data/parsing/grammar/pattern/record.res index 424baffc8e6..644c2e17a79 100644 --- a/tests/syntax_tests/data/parsing/grammar/pattern/record.res +++ b/tests/syntax_tests/data/parsing/grammar/pattern/record.res @@ -88,3 +88,19 @@ for {a, _} in 0 to 10 { () } for (({a, _}) in 0 to 10) { () } for ({a, _} in 0 to 10) { () } for (({a} : myRecord) in 0 to 10) { () } + +// Record rest patterns +let {a, ...rest} = x +let {a, ...b as rest} = x +let {a, ...M.t as rest} = x +let {a, b, ...M.Sub.t as rest} = x + +switch x { +| {a, ...rest} => () +| {a, ...b as rest} => () +| {a, ...M.t as rest} => () +} + +let f = ({a, ...rest}) => () +let f = ({a, ...b as rest}) => () +let f = ({a, ...M.t as rest}) => () diff --git a/tests/syntax_tests/data/parsing/recovery/pattern/expected/parenthesized.res.txt b/tests/syntax_tests/data/parsing/recovery/pattern/expected/parenthesized.res.txt index ca5a43ff607..62c41decb2f 100644 --- a/tests/syntax_tests/data/parsing/recovery/pattern/expected/parenthesized.res.txt +++ b/tests/syntax_tests/data/parsing/recovery/pattern/expected/parenthesized.res.txt @@ -60,6 +60,6 @@ ;;match x with | a -> () | [|a;b|] -> () - | { a; b } -> () + | { a } -> () | 1::[] -> () | (1, 2) -> () \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/recovery/pattern/expected/record.res.txt b/tests/syntax_tests/data/parsing/recovery/pattern/expected/record.res.txt index 68b19a38259..2cc87429258 100644 --- a/tests/syntax_tests/data/parsing/recovery/pattern/expected/record.res.txt +++ b/tests/syntax_tests/data/parsing/recovery/pattern/expected/record.res.txt @@ -9,18 +9,4 @@ Did you forget a `}` here? - - Syntax error! - syntax_tests/data/parsing/recovery/pattern/record.res:3:7-14 - - 1 │ switch x { - 2 │ | {a, b: {x, y => () - 3 │ | {...x, y} => () - 4 │ | {a, _, b} => () - 5 │ } - - Record spread (`...`) is not supported in pattern matches. -Explanation: you can't collect a subset of a record's field into its own record, since a record needs an explicit declaration and that subset wouldn't have one. -Solution: you need to pull out each field you want explicitly. - -;;match x with | { a; b = { x; y } } -> () | { x; y } -> () | { a; b } -> () \ No newline at end of file +;;match x with | { a; b = { x; y } } -> () | { y } -> () | { a; b } -> () \ No newline at end of file diff --git a/tests/tests/src/record_rest_test.mjs b/tests/tests/src/record_rest_test.mjs new file mode 100644 index 00000000000..8635475f183 --- /dev/null +++ b/tests/tests/src/record_rest_test.mjs @@ -0,0 +1,35 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + + +let rest = ((({name, ...__rest}) => __rest))({ + name: "test", + version: "1.0", + debug: true +}); + +function describe(c) { + let rest = ((({name, ...__rest}) => __rest))(c); + return [ + c.name, + rest + ]; +} + +function getName(param) { + return param.name; +} + +function extractClassName(param) { + return ((({className, ...__rest}) => __rest))(param); +} + +let name = "test"; + +export { + rest, + name, + describe, + getName, + extractClassName, +} +/* No side effect */ diff --git a/tests/tests/src/record_rest_test.res b/tests/tests/src/record_rest_test.res new file mode 100644 index 00000000000..74c66872761 --- /dev/null +++ b/tests/tests/src/record_rest_test.res @@ -0,0 +1,41 @@ +type config = { + name: string, + version: string, + debug: bool, +} + +type subConfig = { + version: string, + debug: bool, +} + +// Basic rest pattern in let binding +let {name, ...subConfig as rest} = ({name: "test", version: "1.0", debug: true}: config) +let _ = (name, rest) + +// Rest pattern in match arm +let describe = (c: config) => + switch c { + | {name, ...subConfig as rest} => (name, rest) + } + +// Rest pattern in function parameter +let getName = ({name, ...subConfig as _rest}: config) => name + +// Optional field overlap: className is in both explicit (as optional) and rest type +type fullProps = { + className?: string, + style?: string, + onClick: unit => unit, +} + +type baseProps = { + className?: string, + style?: string, + onClick: unit => unit, +} + +let extractClassName = ({?className, ...baseProps as rest}: fullProps) => { + let _ = className + rest +} From f353016cc1dc4e919cbc58ac41ad7ee4e26ce276 Mon Sep 17 00:00:00 2001 From: tsnobip Date: Tue, 31 Mar 2026 10:57:30 +0200 Subject: [PATCH 02/22] support type with parameter for record rest --- compiler/ml/typecore.ml | 32 +++++++++++++++---- compiler/syntax/src/res_core.ml | 14 +++++--- .../grammar/pattern/expected/record.res.txt | 6 +++- .../data/parsing/grammar/pattern/record.res | 6 ++++ .../printer/pattern/expected/record.res.txt | 7 ++++ .../data/printer/pattern/record.res | 9 +++++- tests/tests/src/record_rest_test.mjs | 14 ++++++++ tests/tests/src/record_rest_test.res | 16 ++++++++++ 8 files changed, 90 insertions(+), 14 deletions(-) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 47f4e6b8753..9c0ea49ebc6 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -1571,11 +1571,11 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp | None -> None | Some rest_pat -> (* Extract type annotation and binding name from rest pattern *) - let rest_type_lid, rest_name = + let rest_type_lid, rest_name, rest_type_args_syntax = match rest_pat.ppat_desc with | Ppat_constraint ({ppat_desc = Ppat_var name}, cty) -> ( match cty.ptyp_desc with - | Ptyp_constr (lid, []) -> (lid, name) + | Ptyp_constr (lid, type_args) -> (lid, name, type_args) | _ -> raise (Error (rest_pat.ppat_loc, !env, Record_rest_invalid_type))) @@ -1674,12 +1674,30 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp (Ident.name rest_label.ld_id, rest_type_lid.txt) ))) rest_labels | [] -> ()); + let rest_type_args = + match rest_type_args_syntax with + | [] -> List.map (fun _ -> newvar ()) rest_decl.type_params + | args -> + let n_args = List.length args in + let n_params = List.length rest_decl.type_params in + if n_args <> n_params then + raise + (Typetexp.Error + ( rest_type_lid.loc, + !env, + Typetexp.Type_arity_mismatch + (rest_type_lid.txt, n_params, n_args) )); + List.map + (fun sty -> + let cty, force = + Typetexp.transl_simple_type_delayed !env sty + in + pattern_force := force :: !pattern_force; + cty.ctyp_type) + args + in let rest_type_expr = - newgenty - (Tconstr - ( rest_path, - List.map (fun _ -> newvar ()) rest_decl.type_params, - ref Mnil )) + newgenty (Tconstr (rest_path, rest_type_args, ref Mnil)) in let rest_ident = enter_variable rest_pat.ppat_loc rest_name rest_type_expr diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index 05e5f157e10..8151acf7bd4 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -1523,10 +1523,11 @@ and parse_record_pattern_row p = let start_pos = p.Parser.start_pos in match p.Parser.token with | Uident _ -> - (* ...ModulePath.t as name *) + (* ...ModulePath.t<'a> as name *) let type_path = parse_value_path p in let type_loc = type_path.loc in - let core_type = Ast_helper.Typ.constr ~loc:type_loc type_path [] in + let type_args = parse_type_constructor_args ~constr_name:type_path p in + let core_type = Ast_helper.Typ.constr ~loc:type_loc type_path type_args in Parser.expect As p; let name_start = p.start_pos in let name = @@ -1547,14 +1548,17 @@ and parse_record_pattern_row p = Some (false, PatRest rest_pat) | Lident ident -> Parser.next p; - if p.Parser.token = As then ( - (* ...typeName as name *) + if p.Parser.token = As || p.Parser.token = Token.LessThan then ( + (* ...typeName<'a> as name *) let type_path = Location.mkloc (Longident.Lident ident) (mk_loc start_pos p.prev_end_pos) in let type_loc = type_path.loc in - let core_type = Ast_helper.Typ.constr ~loc:type_loc type_path [] in + let type_args = parse_type_constructor_args ~constr_name:type_path p in + let core_type = + Ast_helper.Typ.constr ~loc:type_loc type_path type_args + in Parser.expect As p; let name_start = p.start_pos in let name = diff --git a/tests/syntax_tests/data/parsing/grammar/pattern/expected/record.res.txt b/tests/syntax_tests/data/parsing/grammar/pattern/expected/record.res.txt index b1f54e398fb..5a18bd3fa1a 100644 --- a/tests/syntax_tests/data/parsing/grammar/pattern/expected/record.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/pattern/expected/record.res.txt @@ -88,4 +88,8 @@ let { a; b } = x ;;match x with | { a } -> () | { a } -> () | { a } -> () let f [arity:1]{ a } = () let f [arity:1]{ a } = () -let f [arity:1]{ a } = () \ No newline at end of file +let f [arity:1]{ a } = () +let { a } = x +let { a } = x +let { a } = x +let { a } = x \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/pattern/record.res b/tests/syntax_tests/data/parsing/grammar/pattern/record.res index 644c2e17a79..9dc155b1343 100644 --- a/tests/syntax_tests/data/parsing/grammar/pattern/record.res +++ b/tests/syntax_tests/data/parsing/grammar/pattern/record.res @@ -104,3 +104,9 @@ switch x { let f = ({a, ...rest}) => () let f = ({a, ...b as rest}) => () let f = ({a, ...M.t as rest}) => () + +// Polymorphic rest type args +let {a, ...t<'v> as rest} = x +let {a, ...M.t<'v> as rest} = x +let {a, ...M.t as rest} = x +let {a, ...M.t<'a, 'b> as rest} = x diff --git a/tests/syntax_tests/data/printer/pattern/expected/record.res.txt b/tests/syntax_tests/data/printer/pattern/expected/record.res.txt index f2c669ccf15..b1861d258b0 100644 --- a/tests/syntax_tests/data/printer/pattern/expected/record.res.txt +++ b/tests/syntax_tests/data/printer/pattern/expected/record.res.txt @@ -125,3 +125,10 @@ let get_age3 = () => switch x { | {_} => "" } + +// Record rest with polymorphic type args +let {a, ...rest} = x +let {a, ...t<'v> as rest} = x +let {a, ...M.t<'v> as rest} = x +let {a, ...M.t as rest} = x +let {a, ...M.t<'a, 'b> as rest} = x diff --git a/tests/syntax_tests/data/printer/pattern/record.res b/tests/syntax_tests/data/printer/pattern/record.res index b9021af252c..1f389be93db 100644 --- a/tests/syntax_tests/data/printer/pattern/record.res +++ b/tests/syntax_tests/data/printer/pattern/record.res @@ -65,7 +65,14 @@ let get_age3 = () => switch x { | {age, _} => age } -let get_age3 = () => +let get_age3 = () => switch x { | {_} => "" } + +// Record rest with polymorphic type args +let {a, ...rest} = x +let {a, ...t<'v> as rest} = x +let {a, ...M.t<'v> as rest} = x +let {a, ...M.t as rest} = x +let {a, ...M.t<'a, 'b> as rest} = x diff --git a/tests/tests/src/record_rest_test.mjs b/tests/tests/src/record_rest_test.mjs index 8635475f183..267acd804f1 100644 --- a/tests/tests/src/record_rest_test.mjs +++ b/tests/tests/src/record_rest_test.mjs @@ -23,13 +23,27 @@ function extractClassName(param) { return ((({className, ...__rest}) => __rest))(param); } +let intRest = ((({id, ...__rest}) => __rest))({ + id: "1", + value: 42 +}); + +function getValue(param) { + return ((({id, ...__rest}) => __rest))(param); +} + let name = "test"; +let id = "1"; + export { rest, name, describe, getName, extractClassName, + intRest, + id, + getValue, } /* No side effect */ diff --git a/tests/tests/src/record_rest_test.res b/tests/tests/src/record_rest_test.res index 74c66872761..204948823bf 100644 --- a/tests/tests/src/record_rest_test.res +++ b/tests/tests/src/record_rest_test.res @@ -39,3 +39,19 @@ let extractClassName = ({?className, ...baseProps as rest}: fullProps) => { let _ = className rest } + +// Polymorphic rest type +type container<'a> = { + id: string, + value: 'a, +} + +type valueContainer<'a> = { + value: 'a, +} + +let {id, ...valueContainer as intRest} = ({id: "1", value: 42}: container) +let _ = (id, intRest) + +// Polymorphic rest in function parameter +let getValue = ({id: _, ...valueContainer<'a> as rest}: container<'a>) => rest From 61082160d70bbfa534d66068bbe168a1e32bf108 Mon Sep 17 00:00:00 2001 From: tsnobip Date: Tue, 31 Mar 2026 11:12:33 +0200 Subject: [PATCH 03/22] simplify parsing of record rest --- compiler/syntax/src/res_core.ml | 59 +++++++++------------------------ 1 file changed, 16 insertions(+), 43 deletions(-) diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index 8151acf7bd4..ad389295d33 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -1521,13 +1521,14 @@ and parse_record_pattern_row p = | DotDotDot -> ( Parser.next p; let start_pos = p.Parser.start_pos in - match p.Parser.token with - | Uident _ -> - (* ...ModulePath.t<'a> as name *) - let type_path = parse_value_path p in - let type_loc = type_path.loc in - let type_args = parse_type_constructor_args ~constr_name:type_path p in - let core_type = Ast_helper.Typ.constr ~loc:type_loc type_path type_args in + let has_type_annotation = + Parser.lookahead p (fun p -> + ignore (parse_atomic_typ_expr ~attrs:[] p); + p.token = As) + in + if has_type_annotation then ( + (* ...TypeAnnotation<'a> as name *) + let core_type = parse_atomic_typ_expr ~attrs:[] p in Parser.expect As p; let name_start = p.start_pos in let name = @@ -1545,48 +1546,20 @@ and parse_record_pattern_row p = (Ast_helper.Pat.var ~loc:name.loc name) core_type in - Some (false, PatRest rest_pat) - | Lident ident -> - Parser.next p; - if p.Parser.token = As || p.Parser.token = Token.LessThan then ( - (* ...typeName<'a> as name *) - let type_path = - Location.mkloc (Longident.Lident ident) - (mk_loc start_pos p.prev_end_pos) - in - let type_loc = type_path.loc in - let type_args = parse_type_constructor_args ~constr_name:type_path p in - let core_type = - Ast_helper.Typ.constr ~loc:type_loc type_path type_args - in - Parser.expect As p; - let name_start = p.start_pos in - let name = - match p.token with - | Lident id -> - Parser.next p; - Location.mkloc id (mk_loc name_start p.prev_end_pos) - | _ -> - Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); - Location.mkloc "_" (mk_loc name_start p.prev_end_pos) - in - let rest_loc = mk_loc start_pos p.prev_end_pos in - let rest_pat = - Ast_helper.Pat.constraint_ ~loc:rest_loc ~attrs - (Ast_helper.Pat.var ~loc:name.loc name) - core_type - in - Some (false, PatRest rest_pat)) - else + Some (false, PatRest rest_pat)) + else + match p.Parser.token with + | Lident ident -> (* ...name (no type annotation) *) + Parser.next p; let loc = mk_loc start_pos p.prev_end_pos in let rest_pat = Ast_helper.Pat.var ~loc ~attrs (Location.mkloc ident loc) in Some (false, PatRest rest_pat) - | _ -> - (* Fallback: treat as old-style spread (error) *) - Some (true, PatField (parse_record_pattern_row_field ~attrs p))) + | _ -> + (* Fallback: treat as old-style spread (error) *) + Some (true, PatField (parse_record_pattern_row_field ~attrs p))) | Uident _ | Lident _ -> Some (false, PatField (parse_record_pattern_row_field ~attrs p)) | Question -> ( From f9c6325c666c194647b8a8be851138ae34e3bd66 Mon Sep 17 00:00:00 2001 From: tsnobip Date: Tue, 31 Mar 2026 11:19:33 +0200 Subject: [PATCH 04/22] update record spread error message --- compiler/syntax/src/res_core.ml | 8 +++--- .../errors/other/expected/spread.res.txt | 27 ++++++++++++++----- .../data/parsing/errors/other/spread.res | 1 + 3 files changed, 25 insertions(+), 11 deletions(-) diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index ad389295d33..fcfc49b7a53 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -126,11 +126,9 @@ module Error_messages = struct matching currently guarantees to never create new intermediate data." let record_pattern_spread = - "Record spread (`...`) is not supported in pattern matches.\n\ - Explanation: you can't collect a subset of a record's field into its own \ - record, since a record needs an explicit declaration and that subset \ - wouldn't have one.\n\ - Solution: you need to pull out each field you want explicitly." + "Record rest patterns require a type annotation and a binding name.\n\ + Correct syntax: `...typeName as bindingName`\n\ + Example: `let {name, ...Config.t as rest} = myRecord`" (* let recordPatternUnderscore = "Record patterns only support one `_`, at the end." *) [@@live] diff --git a/tests/syntax_tests/data/parsing/errors/other/expected/spread.res.txt b/tests/syntax_tests/data/parsing/errors/other/expected/spread.res.txt index 9384f6d2ff3..fa0445fe0b1 100644 --- a/tests/syntax_tests/data/parsing/errors/other/expected/spread.res.txt +++ b/tests/syntax_tests/data/parsing/errors/other/expected/spread.res.txt @@ -22,20 +22,34 @@ Possible solutions: 2 │ 3 │ let record = {...x, ...y} 4 │ let {...x, ...y} = myRecord - 5 │ + 5 │ let {...M.t} = myRecord Records can only have one `...` spread, at the beginning. Explanation: since records have a known, fixed shape, a spread like `{a, ...b}` wouldn't make sense, as `b` would override every field of `a` anyway. Syntax error! - syntax_tests/data/parsing/errors/other/spread.res:6:13-22 + syntax_tests/data/parsing/errors/other/spread.res:5:9-14 + 3 │ let record = {...x, ...y} 4 │ let {...x, ...y} = myRecord - 5 │ - 6 │ let list{...x, ...y} = myList - 7 │ - 8 │ type t = {...a} + 5 │ let {...M.t} = myRecord + 6 │ + 7 │ let list{...x, ...y} = myList + + Record rest patterns require a type annotation and a binding name. +Correct syntax: `...typeName as bindingName` +Example: `let {name, ...Config.t as rest} = myRecord` + + + Syntax error! + syntax_tests/data/parsing/errors/other/spread.res:7:13-22 + + 5 │ let {...M.t} = myRecord + 6 │ + 7 │ let list{...x, ...y} = myList + 8 │ + 9 │ type t = {...a} List pattern matches only supports one `...` spread, at the end. Explanation: a list spread at the tail is efficient, but a spread in the middle would create new lists; out of performance concern, our pattern matching currently guarantees to never create new intermediate data. @@ -43,6 +57,7 @@ Explanation: a list spread at the tail is efficient, but a spread in the middle let [|arr;_|] = [|1;2;3|] let record = { x with y } let { } = myRecord +let { M.t = t } = myRecord let x::y = myList type nonrec t = { ...: a } diff --git a/tests/syntax_tests/data/parsing/errors/other/spread.res b/tests/syntax_tests/data/parsing/errors/other/spread.res index b6fa643f1f6..06619b39127 100644 --- a/tests/syntax_tests/data/parsing/errors/other/spread.res +++ b/tests/syntax_tests/data/parsing/errors/other/spread.res @@ -2,6 +2,7 @@ let [...arr, _] = [1, 2, 3] let record = {...x, ...y} let {...x, ...y} = myRecord +let {...M.t} = myRecord let list{...x, ...y} = myList From 906df32cd5d4543e1315ed8d419b211f77a9295f Mon Sep 17 00:00:00 2001 From: tsnobip Date: Tue, 31 Mar 2026 12:03:22 +0200 Subject: [PATCH 05/22] improve error message of superfluous fields in rest --- compiler/ml/typecore.ml | 52 ++++++++++++++++++++++++++-------------- compiler/ml/typecore.mli | 2 +- 2 files changed, 35 insertions(+), 19 deletions(-) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 9c0ea49ebc6..a9ffcb9542e 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -100,7 +100,7 @@ type error = | Record_rest_requires_type_annotation of string | Record_rest_not_record of Longident.t | Record_rest_field_not_optional of string * Longident.t - | Record_rest_field_missing of string * Longident.t + | Record_rest_field_missing of string list * Longident.t | Record_rest_extra_field of string * Longident.t exception Error of Location.t * Env.t * error @@ -1639,19 +1639,22 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp (match lbl_pat_list with | (_, label1, _, _) :: _ -> let all_source = label1.lbl_all in - Array.iter - (fun source_label -> - let name = source_label.lbl_name in - if - (not (List.mem name explicit_fields)) - && not (List.mem name rest_field_names) - then - raise - (Error - ( rest_pat.ppat_loc, - !env, - Record_rest_field_missing (name, rest_type_lid.txt) ))) - all_source + let missing = + Array.to_list all_source + |> List.filter_map (fun source_label -> + let name = source_label.lbl_name in + if + (not (List.mem name explicit_fields)) + && not (List.mem name rest_field_names) + then Some name + else None) + in + if missing <> [] then + raise + (Error + ( rest_pat.ppat_loc, + !env, + Record_rest_field_missing (missing, rest_type_lid.txt) )) | [] -> ()); (* Validate: rest type fields must all exist in source *) (match lbl_pat_list with @@ -5249,10 +5252,23 @@ let report_error env loc ppf error = "Field `%s` appears in both the explicit pattern and the rest type `%a`. \ It must be marked as optional (`?%s`) in the explicit pattern." field longident lid field - | Record_rest_field_missing (field, lid) -> - fprintf ppf - "Field `%s` is not covered by the explicit pattern or the rest type `%a`." - field longident lid + | Record_rest_field_missing (fields, lid) -> ( + let field_list = + fields |> List.map (fun f -> "\n- " ^ f) |> String.concat "" + in + match fields with + | [_] -> + fprintf ppf + "The following field is not part of the rest type `%a`:%s\n\n\ + List this field in the record pattern before the spread so it's not \ + present in the rest record." + longident lid field_list + | _ -> + fprintf ppf + "The following fields are not part of the rest type `%a`:%s\n\n\ + List these fields in the record pattern before the spread so they're \ + not present in the rest record." + longident lid field_list) | Record_rest_extra_field (field, lid) -> fprintf ppf "Field `%s` in the rest type `%a` does not exist in the source record \ diff --git a/compiler/ml/typecore.mli b/compiler/ml/typecore.mli index 13129276c10..c7e57c8af04 100644 --- a/compiler/ml/typecore.mli +++ b/compiler/ml/typecore.mli @@ -133,7 +133,7 @@ type error = | Record_rest_requires_type_annotation of string | Record_rest_not_record of Longident.t | Record_rest_field_not_optional of string * Longident.t - | Record_rest_field_missing of string * Longident.t + | Record_rest_field_missing of string list * Longident.t | Record_rest_extra_field of string * Longident.t exception Error of Location.t * Env.t * error From 77ccbcf7c6ce42c75a901aafba5767e3926b163c Mon Sep 17 00:00:00 2001 From: tsnobip Date: Tue, 31 Mar 2026 12:27:53 +0200 Subject: [PATCH 06/22] improve error message of non optional rest field already matched --- compiler/ml/typecore.ml | 49 +++++++++++++++++++++++++--------------- compiler/ml/typecore.mli | 2 +- 2 files changed, 32 insertions(+), 19 deletions(-) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index a9ffcb9542e..d5089daecfa 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -99,7 +99,7 @@ type error = | Record_rest_invalid_type | Record_rest_requires_type_annotation of string | Record_rest_not_record of Longident.t - | Record_rest_field_not_optional of string * Longident.t + | Record_rest_field_not_optional of string list * Longident.t | Record_rest_field_missing of string list * Longident.t | Record_rest_extra_field of string * Longident.t @@ -1622,19 +1622,20 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp rest_labels in (* Validate: fields in both explicit and rest must be optional in the explicit pattern *) - List.iter - (fun rest_field -> - if + let not_optional = + List.filter + (fun rest_field -> List.mem rest_field explicit_fields - && not (List.mem rest_field explicit_optional_fields) - then - raise - (Error - ( rest_pat.ppat_loc, - !env, - Record_rest_field_not_optional - (rest_field, rest_type_lid.txt) ))) - rest_field_names; + && not (List.mem rest_field explicit_optional_fields)) + rest_field_names + in + if not_optional <> [] then + raise + (Error + ( rest_pat.ppat_loc, + !env, + Record_rest_field_not_optional + (not_optional, rest_type_lid.txt) )); (* Validate: all source fields must be in explicit or rest *) (match lbl_pat_list with | (_, label1, _, _) :: _ -> @@ -5247,11 +5248,23 @@ let report_error env loc ppf error = "Type %a is not a record type and cannot be used as a record rest \ pattern." longident lid - | Record_rest_field_not_optional (field, lid) -> - fprintf ppf - "Field `%s` appears in both the explicit pattern and the rest type `%a`. \ - It must be marked as optional (`?%s`) in the explicit pattern." - field longident lid field + | Record_rest_field_not_optional (fields, lid) -> ( + let field_list = + fields |> List.map (fun f -> "\n- " ^ f) |> String.concat "" + in + match fields with + | [field] -> + fprintf ppf + "The following field appears in both the explicit pattern and the rest \ + type `%a`:%s\n\n\ + Mark it as optional (`?%s`) in the explicit pattern." + longident lid field_list field + | _ -> + fprintf ppf + "The following fields appear in both the explicit pattern and the rest \ + type `%a`:%s\n\n\ + Mark them as optional (e.g. `?fieldName`) in the explicit pattern." + longident lid field_list) | Record_rest_field_missing (fields, lid) -> ( let field_list = fields |> List.map (fun f -> "\n- " ^ f) |> String.concat "" diff --git a/compiler/ml/typecore.mli b/compiler/ml/typecore.mli index c7e57c8af04..7d1ac112903 100644 --- a/compiler/ml/typecore.mli +++ b/compiler/ml/typecore.mli @@ -132,7 +132,7 @@ type error = | Record_rest_invalid_type | Record_rest_requires_type_annotation of string | Record_rest_not_record of Longident.t - | Record_rest_field_not_optional of string * Longident.t + | Record_rest_field_not_optional of string list * Longident.t | Record_rest_field_missing of string list * Longident.t | Record_rest_extra_field of string * Longident.t From 453d89f4e572ae5528b0d344fe5df069305ef9b3 Mon Sep 17 00:00:00 2001 From: tsnobip Date: Tue, 31 Mar 2026 12:31:30 +0200 Subject: [PATCH 07/22] add a warning when rest record would be empty --- compiler/ext/warnings.ml | 8 +++++++- compiler/ext/warnings.mli | 1 + compiler/ml/typecore.ml | 9 +++++++++ 3 files changed, 17 insertions(+), 1 deletion(-) diff --git a/compiler/ext/warnings.ml b/compiler/ext/warnings.ml index c768ae4537c..629a4ca759a 100644 --- a/compiler/ext/warnings.ml +++ b/compiler/ext/warnings.ml @@ -75,6 +75,7 @@ type t = (string * top_level_unit_help) option (* 109 *) | Bs_todo of string option (* 110 *) | Bs_private_record_mutation of string (* 111 *) + | Bs_record_rest_empty (* 112 *) (* If you remove a warning, leave a hole in the numbering. NEVER change the numbers of existing warnings. @@ -128,8 +129,9 @@ let number = function | Bs_toplevel_expression_unit _ -> 109 | Bs_todo _ -> 110 | Bs_private_record_mutation _ -> 111 + | Bs_record_rest_empty -> 112 -let last_warning_number = 111 +let last_warning_number = 112 let letter_all = let rec loop i = if i = 0 then [] else i :: loop (i - 1) in @@ -448,6 +450,9 @@ let message = function `%s->ignore`" help_text help_text | _ -> "") + | Bs_record_rest_empty -> + "All fields of the rest type are already present in the explicit pattern. \ + The rest record will always be empty." | Bs_todo maybe_text -> (match maybe_text with | None -> "Todo found." @@ -569,6 +574,7 @@ let descriptions = (109, "Toplevel expression has unit type"); (110, "Todo found"); (111, "Mutation of private record field"); + (112, "Record rest pattern will always be empty"); ] let help_warnings () = diff --git a/compiler/ext/warnings.mli b/compiler/ext/warnings.mli index 46cba811ad7..e7be69baf32 100644 --- a/compiler/ext/warnings.mli +++ b/compiler/ext/warnings.mli @@ -68,6 +68,7 @@ type t = (string * top_level_unit_help) option (* 109 *) | Bs_todo of string option (* 110 *) | Bs_private_record_mutation of string (* 111 *) + | Bs_record_rest_empty (* 112 *) val parse_options : bool -> string -> unit diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index d5089daecfa..63d5f274657 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -1621,6 +1621,15 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp (fun (l : Types.label_declaration) -> Ident.name l.ld_id) rest_labels in + (* Warn if all rest fields are already explicit — the rest record will be empty *) + if + rest_field_names <> [] + && List.for_all + (fun f -> List.mem f explicit_fields) + rest_field_names + then + Location.prerr_warning rest_pat.ppat_loc + Warnings.Bs_record_rest_empty; (* Validate: fields in both explicit and rest must be optional in the explicit pattern *) let not_optional = List.filter From 23ea968a6a09c18bb27989d48a72b7c5777838aa Mon Sep 17 00:00:00 2001 From: tsnobip Date: Tue, 31 Mar 2026 12:48:42 +0200 Subject: [PATCH 08/22] add fixture tests for error/warning messages --- compiler/ml/typecore.ml | 18 +++++++++--------- .../record_rest_empty_warning.res.expected | 10 ++++++++++ .../record_rest_extra_field.res.expected | 10 ++++++++++ .../record_rest_field_missing.res.expected | 14 ++++++++++++++ ...record_rest_field_not_optional.res.expected | 13 +++++++++++++ .../record_rest_invalid_type.res.expected | 9 +++++++++ .../record_rest_not_record.res.expected | 10 ++++++++++ ..._rest_requires_type_annotation.res.expected | 9 +++++++++ .../fixtures/record_rest_empty_warning.res | 3 +++ .../fixtures/record_rest_extra_field.res | 3 +++ .../fixtures/record_rest_field_missing.res | 3 +++ .../record_rest_field_not_optional.res | 3 +++ .../fixtures/record_rest_invalid_type.res | 2 ++ .../fixtures/record_rest_not_record.res | 3 +++ .../record_rest_requires_type_annotation.res | 2 ++ 15 files changed, 103 insertions(+), 9 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/record_rest_empty_warning.res.expected create mode 100644 tests/build_tests/super_errors/expected/record_rest_extra_field.res.expected create mode 100644 tests/build_tests/super_errors/expected/record_rest_field_missing.res.expected create mode 100644 tests/build_tests/super_errors/expected/record_rest_field_not_optional.res.expected create mode 100644 tests/build_tests/super_errors/expected/record_rest_invalid_type.res.expected create mode 100644 tests/build_tests/super_errors/expected/record_rest_not_record.res.expected create mode 100644 tests/build_tests/super_errors/expected/record_rest_requires_type_annotation.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/record_rest_empty_warning.res create mode 100644 tests/build_tests/super_errors/fixtures/record_rest_extra_field.res create mode 100644 tests/build_tests/super_errors/fixtures/record_rest_field_missing.res create mode 100644 tests/build_tests/super_errors/fixtures/record_rest_field_not_optional.res create mode 100644 tests/build_tests/super_errors/fixtures/record_rest_invalid_type.res create mode 100644 tests/build_tests/super_errors/fixtures/record_rest_not_record.res create mode 100644 tests/build_tests/super_errors/fixtures/record_rest_requires_type_annotation.res diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 63d5f274657..4e4144cf352 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -1621,15 +1621,6 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp (fun (l : Types.label_declaration) -> Ident.name l.ld_id) rest_labels in - (* Warn if all rest fields are already explicit — the rest record will be empty *) - if - rest_field_names <> [] - && List.for_all - (fun f -> List.mem f explicit_fields) - rest_field_names - then - Location.prerr_warning rest_pat.ppat_loc - Warnings.Bs_record_rest_empty; (* Validate: fields in both explicit and rest must be optional in the explicit pattern *) let not_optional = List.filter @@ -1687,6 +1678,15 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp (Ident.name rest_label.ld_id, rest_type_lid.txt) ))) rest_labels | [] -> ()); + (* Warn if all rest fields are already explicit — the rest record will be empty *) + if + rest_field_names <> [] + && List.for_all + (fun f -> List.mem f explicit_fields) + rest_field_names + then + Location.prerr_warning rest_pat.ppat_loc + Warnings.Bs_record_rest_empty; let rest_type_args = match rest_type_args_syntax with | [] -> List.map (fun _ -> newvar ()) rest_decl.type_params diff --git a/tests/build_tests/super_errors/expected/record_rest_empty_warning.res.expected b/tests/build_tests/super_errors/expected/record_rest_empty_warning.res.expected new file mode 100644 index 00000000000..30d52282aef --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_rest_empty_warning.res.expected @@ -0,0 +1,10 @@ + + Warning number 111 + /.../fixtures/record_rest_empty_warning.res:3:16-26 + + 1 │ type source = {a: int, b?: string} + 2 │ type sub = {b?: string} + 3 │ let {a, ?b, ...sub as rest} = ({a: 1}: source) + 4 │ + + All fields of the rest type are already present in the explicit pattern. The rest record will always be empty. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/record_rest_extra_field.res.expected b/tests/build_tests/super_errors/expected/record_rest_extra_field.res.expected new file mode 100644 index 00000000000..5250f826e70 --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_rest_extra_field.res.expected @@ -0,0 +1,10 @@ + + We've found a bug for you! + /.../fixtures/record_rest_extra_field.res:3:12-14 + + 1 │ type source = {a: int, x: int} + 2 │ type sub = {a: int, b: string} + 3 │ let {x, ...sub as rest} = ({a: 1, x: 2}: source) + 4 │ + + Field `b` in the rest type `sub` does not exist in the source record type. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/record_rest_field_missing.res.expected b/tests/build_tests/super_errors/expected/record_rest_field_missing.res.expected new file mode 100644 index 00000000000..aafee7f85e0 --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_rest_field_missing.res.expected @@ -0,0 +1,14 @@ + + We've found a bug for you! + /.../fixtures/record_rest_field_missing.res:3:12-22 + + 1 │ type source = {a: int, b: string, c: bool, d: float} + 2 │ type sub = {b: string} + 3 │ let {a, ...sub as rest} = ({a: 1, b: "x", c: true, d: 1.0}: source) + 4 │ + + The following fields are not part of the rest type `sub`: +- c +- d + +List these fields in the record pattern before the spread so they're not present in the rest record. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/record_rest_field_not_optional.res.expected b/tests/build_tests/super_errors/expected/record_rest_field_not_optional.res.expected new file mode 100644 index 00000000000..458da763631 --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_rest_field_not_optional.res.expected @@ -0,0 +1,13 @@ + + We've found a bug for you! + /.../fixtures/record_rest_field_not_optional.res:3:12-22 + + 1 │ type source = {a?: int, b?: string, c: bool} + 2 │ type sub = {a?: int, b?: string} + 3 │ let {a, ...sub as rest}: source = {c: true} + 4 │ + + The following field appears in both the explicit pattern and the rest type `sub`: +- a + +Mark it as optional (`?a`) in the explicit pattern. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/record_rest_invalid_type.res.expected b/tests/build_tests/super_errors/expected/record_rest_invalid_type.res.expected new file mode 100644 index 00000000000..98047fce9cd --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_rest_invalid_type.res.expected @@ -0,0 +1,9 @@ + + We've found a bug for you! + /.../fixtures/record_rest_invalid_type.res:2:12-21 + + 1 │ type source = {a: int, b: string} + 2 │ let {a, ...'a as rest} = ({a: 1, b: "x"}: source) + 3 │ + + Record rest pattern must have the form: ...Type.t as name \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/record_rest_not_record.res.expected b/tests/build_tests/super_errors/expected/record_rest_not_record.res.expected new file mode 100644 index 00000000000..a2c34a5ace0 --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_rest_not_record.res.expected @@ -0,0 +1,10 @@ + + We've found a bug for you! + /.../fixtures/record_rest_not_record.res:3:12-20 + + 1 │ type source = {a: int, b: string} + 2 │ type notRecord = One | Two + 3 │ let {a, ...notRecord as rest} = ({a: 1, b: "x"}: source) + 4 │ + + Type notRecord is not a record type and cannot be used as a record rest pattern. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/record_rest_requires_type_annotation.res.expected b/tests/build_tests/super_errors/expected/record_rest_requires_type_annotation.res.expected new file mode 100644 index 00000000000..49483d2c99e --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_rest_requires_type_annotation.res.expected @@ -0,0 +1,9 @@ + + We've found a bug for you! + /.../fixtures/record_rest_requires_type_annotation.res:2:12-18 + + 1 │ type source = {a: int, b: string} + 2 │ let {a, ...theRest} = ({a: 1, b: "x"}: source) + 3 │ + + Record rest pattern `...theRest` requires a type annotation. Use `...Type.t as theRest`. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/record_rest_empty_warning.res b/tests/build_tests/super_errors/fixtures/record_rest_empty_warning.res new file mode 100644 index 00000000000..817b139276c --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/record_rest_empty_warning.res @@ -0,0 +1,3 @@ +type source = {a: int, b?: string} +type sub = {b?: string} +let {a, ?b, ...sub as rest} = ({a: 1}: source) diff --git a/tests/build_tests/super_errors/fixtures/record_rest_extra_field.res b/tests/build_tests/super_errors/fixtures/record_rest_extra_field.res new file mode 100644 index 00000000000..d7c8f59eb92 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/record_rest_extra_field.res @@ -0,0 +1,3 @@ +type source = {a: int, x: int} +type sub = {a: int, b: string} +let {x, ...sub as rest} = ({a: 1, x: 2}: source) diff --git a/tests/build_tests/super_errors/fixtures/record_rest_field_missing.res b/tests/build_tests/super_errors/fixtures/record_rest_field_missing.res new file mode 100644 index 00000000000..8a7fadc14ce --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/record_rest_field_missing.res @@ -0,0 +1,3 @@ +type source = {a: int, b: string, c: bool, d: float} +type sub = {b: string} +let {a, ...sub as rest} = ({a: 1, b: "x", c: true, d: 1.0}: source) diff --git a/tests/build_tests/super_errors/fixtures/record_rest_field_not_optional.res b/tests/build_tests/super_errors/fixtures/record_rest_field_not_optional.res new file mode 100644 index 00000000000..d5bffdb282f --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/record_rest_field_not_optional.res @@ -0,0 +1,3 @@ +type source = {a?: int, b?: string, c: bool} +type sub = {a?: int, b?: string} +let {a, ...sub as rest}: source = {c: true} diff --git a/tests/build_tests/super_errors/fixtures/record_rest_invalid_type.res b/tests/build_tests/super_errors/fixtures/record_rest_invalid_type.res new file mode 100644 index 00000000000..42dc2a4615d --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/record_rest_invalid_type.res @@ -0,0 +1,2 @@ +type source = {a: int, b: string} +let {a, ...'a as rest} = ({a: 1, b: "x"}: source) diff --git a/tests/build_tests/super_errors/fixtures/record_rest_not_record.res b/tests/build_tests/super_errors/fixtures/record_rest_not_record.res new file mode 100644 index 00000000000..e7563ab2c02 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/record_rest_not_record.res @@ -0,0 +1,3 @@ +type source = {a: int, b: string} +type notRecord = One | Two +let {a, ...notRecord as rest} = ({a: 1, b: "x"}: source) diff --git a/tests/build_tests/super_errors/fixtures/record_rest_requires_type_annotation.res b/tests/build_tests/super_errors/fixtures/record_rest_requires_type_annotation.res new file mode 100644 index 00000000000..fbbb66df80a --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/record_rest_requires_type_annotation.res @@ -0,0 +1,2 @@ +type source = {a: int, b: string} +let {a, ...theRest} = ({a: 1, b: "x"}: source) From 0841f1d4cb3d2795d5deaa047805772b9e253300 Mon Sep 17 00:00:00 2001 From: tsnobip Date: Tue, 31 Mar 2026 12:50:20 +0200 Subject: [PATCH 09/22] add changelog --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 070c866edc8..1b29e9179d2 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -118,6 +118,7 @@ - Reanalyze: add glob pattern support for suppress/unsuppress configurations (e.g., `"src/generated/**"`). https://github.com/rescript-lang/rescript/pull/8277 - Add optional `~locales` and `~options` parameters to `String.localeCompare`. https://github.com/rescript-lang/rescript/pull/8287 - Support inline records in external definitions. https://github.com/rescript-lang/rescript/pull/8304 +- Add support for pattern matching/destructuring of record rest. https://github.com/rescript-lang/rescript/pull/8317 #### :bug: Bug fix From aaecac9b2aef20e167d52c0b235838f939224511 Mon Sep 17 00:00:00 2001 From: tsnobip Date: Wed, 1 Apr 2026 12:54:05 +0200 Subject: [PATCH 10/22] address comments (parsetree0 PPX roundtrips, nested rest, etc) --- compiler/ml/ast_iterator.ml | 5 +- compiler/ml/ast_mapper_from0.ml | 3 +- compiler/ml/ast_mapper_to0.ml | 8 ++- compiler/ml/depend.ml | 3 +- compiler/ml/matching.ml | 69 +++++-------------- compiler/ml/parsetree0.ml | 14 ++++ compiler/ml/typecore.ml | 4 +- compiler/ml/typedtree.ml | 10 +++ compiler/syntax/src/res_core.ml | 13 +++- .../expected/record_rest_duplicate.res.txt | 11 +++ .../errors/other/expected/spread.res.txt | 13 ++++ .../errors/other/record_rest_duplicate.res | 1 + tests/tests/src/record_rest_test.mjs | 32 ++++++++- tests/tests/src/record_rest_test.res | 18 +++++ tests/tools_tests/ppx/ZRecordRest.res | 14 ++++ .../src/expected/ZRecordRest.res.jsout | 14 ++++ 16 files changed, 174 insertions(+), 58 deletions(-) create mode 100644 tests/syntax_tests/data/parsing/errors/other/expected/record_rest_duplicate.res.txt create mode 100644 tests/syntax_tests/data/parsing/errors/other/record_rest_duplicate.res create mode 100644 tests/tools_tests/ppx/ZRecordRest.res create mode 100644 tests/tools_tests/src/expected/ZRecordRest.res.jsout diff --git a/compiler/ml/ast_iterator.ml b/compiler/ml/ast_iterator.ml index 75a55d88d0d..66be16cf836 100644 --- a/compiler/ml/ast_iterator.ml +++ b/compiler/ml/ast_iterator.ml @@ -407,12 +407,13 @@ 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, _rest) -> + | Ppat_record (lpl, _cf, rest) -> List.iter (fun {lid; x = pat} -> iter_loc sub lid; sub.pat sub pat) - lpl + lpl; + iter_opt (sub.pat sub) rest | Ppat_array pl -> List.iter (sub.pat sub) pl | Ppat_or (p1, p2) -> sub.pat sub p1; diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index c4e8f80bb35..e565cda05b5 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -656,7 +656,8 @@ 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 + let rest, attrs = Parsetree0.get_record_rest_attr attrs in + record ~loc ~attrs ?rest (Ext_list.map lpl (fun (lid, p) -> let lid1 = map_loc sub lid in let p1 = sub.pat sub p in diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index a5773871577..73aea1625f5 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -601,7 +601,13 @@ module P = struct | Ppat_construct (l, p) -> 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, _rest) -> + | Ppat_record (lpl, cf, rest) -> + let attrs = + match rest with + | None -> attrs + | Some rest_pat -> + Parsetree0.add_record_rest_attr ~rest:(sub.pat sub rest_pat) attrs + in record ~loc ~attrs (Ext_list.map lpl (fun {lid; x = p; opt = optional} -> let lid1 = map_loc sub lid in diff --git a/compiler/ml/depend.ml b/compiler/ml/depend.ml index 49c5463b124..dc5442cdc6a 100644 --- a/compiler/ml/depend.ml +++ b/compiler/ml/depend.ml @@ -184,7 +184,8 @@ let rec add_pattern bv pat = (fun {lid = lbl; x = p} -> add bv lbl; add_pattern bv p) - pl + pl; + add_opt add_pattern bv _rest | Ppat_array pl -> List.iter (add_pattern bv) pl | Ppat_or (p1, p2) -> add_pattern bv p1; diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index 8d3912a90c7..ac7b952aeac 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -543,6 +543,14 @@ let simplify_or p = in try simpl_rec p with Var p -> p +let bind_record_rest loc arg rest action = + Llet + ( Strict, + Pgenval, + rest.rest_ident, + Lprim (Precord_spread_new rest.excluded_labels, [arg], loc), + action ) + let simplify_cases args cls = match args with | [] -> assert false @@ -560,7 +568,12 @@ let simplify_cases args cls = | Tpat_record (lbls, closed, rest) -> let all_lbls = all_record_args lbls in let full_pat = - {pat with pat_desc = Tpat_record (all_lbls, closed, rest)} + {pat with pat_desc = Tpat_record (all_lbls, closed, None)} + in + let action = + match rest with + | None -> action + | Some rest -> bind_record_rest pat.pat_loc arg rest action in (full_pat :: patl, action) :: simplify rem | Tpat_or _ -> ( @@ -617,8 +630,11 @@ let rec extract_vars r p = | Tpat_var (id, _) -> Ident_set.add id r | Tpat_alias (p, id, _) -> extract_vars (Ident_set.add id r) p | Tpat_tuple pats -> List.fold_left extract_vars r pats - | Tpat_record (lpats, _, _rest) -> - List.fold_left (fun r (_, _, p, _) -> extract_vars r p) r lpats + | Tpat_record (lpats, _, rest) -> ( + let r = List.fold_left (fun r (_, _, p, _) -> extract_vars r p) r lpats in + match rest with + | None -> r + | Some rest -> IdentSet.add rest.rest_ident r) | Tpat_construct (_, _, pats) -> List.fold_left extract_vars r pats | Tpat_array pats -> List.fold_left extract_vars r pats | Tpat_variant (_, Some p, _) -> extract_vars r p @@ -2742,32 +2758,7 @@ let partial_function loc () = ], loc ) -(* For record patterns with rest, inject the rest binding into the action body *) -let inject_record_rest_binding param (pat, action) = - match pat.pat_desc with - | Tpat_record (_, _, Some rest) -> - let action_with_rest = - Llet - ( Strict, - Pgenval, - rest.rest_ident, - Lprim (Precord_spread_new rest.excluded_labels, [param], pat.pat_loc), - action ) - in - let pat_without_rest = - { - pat with - pat_desc = - (match pat.pat_desc with - | Tpat_record (fields, closed, _) -> Tpat_record (fields, closed, None) - | _ -> pat.pat_desc); - } - in - (pat_without_rest, action_with_rest) - | _ -> (pat, action) - let for_function loc repr param pat_act_list partial = - let pat_act_list = List.map (inject_record_rest_binding param) pat_act_list in compile_matching repr (partial_function loc) param pat_act_list partial (* In the following two cases, exhaustiveness info is not available! *) @@ -2836,28 +2827,6 @@ let for_let loc param pat body = | Tpat_var (id, _) -> (* fast path, and keep track of simple bindings to unboxable numbers *) Llet (Strict, Pgenval, id, param, body) - | Tpat_record (_, _, Some rest) -> - (* Record pattern with rest: compile the explicit field bindings normally, - then add a binding for the rest ident using Precord_spread_new *) - let body_with_rest = - Llet - ( Strict, - Pgenval, - rest.rest_ident, - Lprim (Precord_spread_new rest.excluded_labels, [param], loc), - body ) - in - (* Compile the explicit fields pattern (without rest) into the body *) - let pat_without_rest = - { - pat with - pat_desc = - (match pat.pat_desc with - | Tpat_record (fields, closed, _) -> Tpat_record (fields, closed, None) - | _ -> pat.pat_desc); - } - in - simple_for_let loc param pat_without_rest body_with_rest | _ -> simple_for_let loc param pat body (* Handling of tupled functions and matchings *) diff --git a/compiler/ml/parsetree0.ml b/compiler/ml/parsetree0.ml index ef786dfd25d..db5d75ee1a9 100644 --- a/compiler/ml/parsetree0.ml +++ b/compiler/ml/parsetree0.ml @@ -597,6 +597,7 @@ and module_binding = { let optional_attr = (Location.mknoloc "res.optional", Parsetree.PStr []) let optional_attr0 = (Location.mknoloc "res.optional", PStr []) +let record_rest_attr_name = "res.record_rest" let add_optional_attr ~optional attrs = if optional then optional_attr0 :: attrs else attrs @@ -608,3 +609,16 @@ let get_optional_attr attrs_ = let attrs = remove_optional_attr attrs_ in let optional = List.length attrs <> List.length attrs_ in (optional, attrs) + +let add_record_rest_attr ~rest attrs = + (Location.mknoloc record_rest_attr_name, PPat (rest, None)) :: attrs + +let get_record_rest_attr attrs_ = + let rec remove_record_rest_attr acc = function + | ({Location.txt = attr_name; _}, Parsetree.PPat (rest, None)) :: attrs + when attr_name = record_rest_attr_name -> + (Some rest, List.rev_append acc attrs) + | attr :: attrs -> remove_record_rest_attr (attr :: acc) attrs + | [] -> (None, List.rev acc) + in + remove_record_rest_attr [] attrs_ diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 4e4144cf352..057760118b3 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -2292,7 +2292,9 @@ let iter_ppat f p = | Ppat_open (_, p) | Ppat_constraint (p, _) -> f p - | Ppat_record (args, _flag, _rest) -> List.iter (fun {x = p} -> f p) args + | Ppat_record (args, _flag, rest) -> + List.iter (fun {x = p} -> f p) args; + may f rest let contains_polymorphic_variant p = let rec loop p = diff --git a/compiler/ml/typedtree.ml b/compiler/ml/typedtree.ml index cbabf20ffd7..5557c2beefe 100644 --- a/compiler/ml/typedtree.ml +++ b/compiler/ml/typedtree.ml @@ -504,6 +504,16 @@ let rec alpha_pat env p = let new_p = alpha_pat env p1 in try {p with pat_desc = Tpat_alias (new_p, alpha_var env id, s)} with Not_found -> new_p) + | Tpat_record (lpats, closed, Some rest) -> + let rest_ident = + try alpha_var env rest.rest_ident with Not_found -> rest.rest_ident + in + let lpats = + List.map + (fun (lid, lbl, pat, opt) -> (lid, lbl, alpha_pat env pat, opt)) + lpats + in + {p with pat_desc = Tpat_record (lpats, closed, Some {rest with rest_ident})} | d -> {p with pat_desc = map_pattern_desc (alpha_pat env) d} let mkloc = Location.mkloc diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index fcfc49b7a53..8b989be7b1c 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -129,6 +129,11 @@ module Error_messages = struct "Record rest patterns require a type annotation and a binding name.\n\ Correct syntax: `...typeName as bindingName`\n\ Example: `let {name, ...Config.t as rest} = myRecord`" + + let record_pattern_multiple_rest = + "Record patterns can only have one `...` rest clause.\n\ + Use a single `...typeName as bindingName` clause to capture the remaining \ + fields." (* let recordPatternUnderscore = "Record patterns only support one `_`, at the end." *) [@@live] @@ -1614,7 +1619,13 @@ and parse_record_pattern ~attrs p = Parser.err ~start_pos:pattern.Parsetree.ppat_loc.loc_start p (Diagnostics.message Error_messages.record_pattern_spread)); (field :: fields, flag, rest) - | PatRest rest_pat -> (fields, flag, Some rest_pat) + | PatRest rest_pat -> ( + match rest with + | None -> (fields, flag, Some rest_pat) + | Some _ -> + Parser.err ~start_pos:rest_pat.Parsetree.ppat_loc.loc_start p + (Diagnostics.message ErrorMessages.record_pattern_multiple_rest); + (fields, flag, rest)) | PatUnderscore -> (fields, flag, rest)) ([], flag, None) raw_fields in diff --git a/tests/syntax_tests/data/parsing/errors/other/expected/record_rest_duplicate.res.txt b/tests/syntax_tests/data/parsing/errors/other/expected/record_rest_duplicate.res.txt new file mode 100644 index 00000000000..c4c210586f3 --- /dev/null +++ b/tests/syntax_tests/data/parsing/errors/other/expected/record_rest_duplicate.res.txt @@ -0,0 +1,11 @@ + + Syntax error! + syntax_tests/data/parsing/errors/other/record_rest_duplicate.res:1:9-51 + + 1 │ let {...Config.t as first, ...Config.t as second} = myRecord + 2 │ + + Record patterns can only have one `...` rest clause. +Use a single `...typeName as bindingName` clause to capture the remaining fields. + +let { } = myRecord \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/errors/other/expected/spread.res.txt b/tests/syntax_tests/data/parsing/errors/other/expected/spread.res.txt index fa0445fe0b1..c75eaef1117 100644 --- a/tests/syntax_tests/data/parsing/errors/other/expected/spread.res.txt +++ b/tests/syntax_tests/data/parsing/errors/other/expected/spread.res.txt @@ -28,6 +28,19 @@ Possible solutions: Explanation: since records have a known, fixed shape, a spread like `{a, ...b}` wouldn't make sense, as `b` would override every field of `a` anyway. + Syntax error! + syntax_tests/data/parsing/errors/other/spread.res:4:9-18 + + 2 │ + 3 │ let record = {...x, ...y} + 4 │ let {...x, ...y} = myRecord + 5 │ let {...M.t} = myRecord + 6 │ + + Record patterns can only have one `...` rest clause. +Use a single `...typeName as bindingName` clause to capture the remaining fields. + + Syntax error! syntax_tests/data/parsing/errors/other/spread.res:5:9-14 diff --git a/tests/syntax_tests/data/parsing/errors/other/record_rest_duplicate.res b/tests/syntax_tests/data/parsing/errors/other/record_rest_duplicate.res new file mode 100644 index 00000000000..ac10357c3a6 --- /dev/null +++ b/tests/syntax_tests/data/parsing/errors/other/record_rest_duplicate.res @@ -0,0 +1 @@ +let {...Config.t as first, ...Config.t as second} = myRecord diff --git a/tests/tests/src/record_rest_test.mjs b/tests/tests/src/record_rest_test.mjs index 267acd804f1..a83523f5cbf 100644 --- a/tests/tests/src/record_rest_test.mjs +++ b/tests/tests/src/record_rest_test.mjs @@ -32,6 +32,32 @@ function getValue(param) { return ((({id, ...__rest}) => __rest))(param); } +function getTupleRest(param) { + return ((({name, ...__rest}) => __rest))(param[0]); +} + +let tupleRest = getTupleRest([ + { + name: "tuple", + version: "2.0", + debug: false + }, + 1 +]); + +function getWrappedRest(wrapped) { + return ((({name, ...__rest}) => __rest))(wrapped._0); +} + +let wrappedRest = getWrappedRest({ + TAG: "Wrap", + _0: { + name: "wrapped", + version: "3.0", + debug: true + } +}); + let name = "test"; let id = "1"; @@ -45,5 +71,9 @@ export { intRest, id, getValue, + getTupleRest, + tupleRest, + getWrappedRest, + wrappedRest, } -/* No side effect */ +/* tupleRest Not a pure module */ diff --git a/tests/tests/src/record_rest_test.res b/tests/tests/src/record_rest_test.res index 204948823bf..73bc8b1c531 100644 --- a/tests/tests/src/record_rest_test.res +++ b/tests/tests/src/record_rest_test.res @@ -55,3 +55,21 @@ let _ = (id, intRest) // Polymorphic rest in function parameter let getValue = ({id: _, ...valueContainer<'a> as rest}: container<'a>) => rest + +type wrapped = + | Wrap(config) + | Mirror(config) + +// Nested record rest in a tuple pattern +let getTupleRest = (({name: _, ...subConfig as rest}, _): (config, int)) => rest + +let tupleRest = getTupleRest((({name: "tuple", version: "2.0", debug: false}: config), 1)) + +// Nested record rest in constructor and or-pattern matches +let getWrappedRest = wrapped => + switch wrapped { + | Wrap({name: _, ...subConfig as rest}) + | Mirror({name: _, ...subConfig as rest}) => rest + } + +let wrappedRest = getWrappedRest(Wrap({name: "wrapped", version: "3.0", debug: true})) diff --git a/tests/tools_tests/ppx/ZRecordRest.res b/tests/tools_tests/ppx/ZRecordRest.res new file mode 100644 index 00000000000..d70c12df4cb --- /dev/null +++ b/tests/tools_tests/ppx/ZRecordRest.res @@ -0,0 +1,14 @@ +let _ = 0 + +type config = { + name: string, + version: string, + debug: bool, +} + +type subConfig = { + version: string, + debug: bool, +} + +let extract = ({name, ...subConfig as rest}: config) => (name, rest) diff --git a/tests/tools_tests/src/expected/ZRecordRest.res.jsout b/tests/tools_tests/src/expected/ZRecordRest.res.jsout new file mode 100644 index 00000000000..acc2f53a8e2 --- /dev/null +++ b/tests/tools_tests/src/expected/ZRecordRest.res.jsout @@ -0,0 +1,14 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE +'use strict'; + + +function extract(param) { + let rest = ((({name, ...__rest}) => __rest))(param); + return [ + param.name, + rest + ]; +} + +exports.extract = extract; +/* No side effect */ From ca77e9cab21e8a1add21f99c62ebd3c76f973f3f Mon Sep 17 00:00:00 2001 From: tsnobip Date: Wed, 1 Apr 2026 13:40:01 +0200 Subject: [PATCH 11/22] support rest of inline record --- compiler/ml/typecore.ml | 18 ++- tests/tests/src/record_rest_test.mjs | 183 +++++++++++++++++++++------ tests/tests/src/record_rest_test.res | 131 +++++++++++++++---- 3 files changed, 271 insertions(+), 61 deletions(-) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 057760118b3..0cbdee25d3c 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -1615,6 +1615,22 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp if opt then Some label.lbl_name else None) lbl_pat_list in + let runtime_excluded_fields = + match lbl_pat_list with + | (_, label1, _, _) :: _ -> ( + match label1.lbl_repres with + | Record_inlined {attrs; _} + when not (Ast_untagged_variants.process_untagged attrs) -> + let tag_name = + match Ast_untagged_variants.process_tag_name attrs with + | Some s -> s + | None -> "TAG" + in + if List.mem tag_name explicit_fields then explicit_fields + else tag_name :: explicit_fields + | _ -> explicit_fields) + | [] -> explicit_fields + in (* Get rest field names *) let rest_field_names = List.map @@ -1721,7 +1737,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp rest_type = rest_type_expr; rest_path; rest_labels; - excluded_labels = explicit_fields; + excluded_labels = runtime_excluded_fields; } in rp k diff --git a/tests/tests/src/record_rest_test.mjs b/tests/tests/src/record_rest_test.mjs index a83523f5cbf..1ee94ebf2fc 100644 --- a/tests/tests/src/record_rest_test.mjs +++ b/tests/tests/src/record_rest_test.mjs @@ -1,13 +1,9 @@ // Generated by ReScript, PLEASE EDIT WITH CARE +import * as Mocha from "mocha"; +import * as Test_utils from "./test_utils.mjs"; -let rest = ((({name, ...__rest}) => __rest))({ - name: "test", - version: "1.0", - debug: true -}); - -function describe(c) { +function describeConfig(c) { let rest = ((({name, ...__rest}) => __rest))(c); return [ c.name, @@ -23,11 +19,6 @@ function extractClassName(param) { return ((({className, ...__rest}) => __rest))(param); } -let intRest = ((({id, ...__rest}) => __rest))({ - id: "1", - value: 42 -}); - function getValue(param) { return ((({id, ...__rest}) => __rest))(param); } @@ -36,44 +27,160 @@ function getTupleRest(param) { return ((({name, ...__rest}) => __rest))(param[0]); } -let tupleRest = getTupleRest([ - { - name: "tuple", - version: "2.0", - debug: false - }, - 1 -]); - function getWrappedRest(wrapped) { return ((({name, ...__rest}) => __rest))(wrapped._0); } -let wrappedRest = getWrappedRest({ - TAG: "Wrap", - _0: { - name: "wrapped", +function getInlineWrappedRest(wrapped) { + return ((({TAG, name, ...__rest}) => __rest))(wrapped); +} + +function getCustomTaggedInlineWrappedRest(wrapped) { + return ((({kind, name, ...__rest}) => __rest))(wrapped); +} + +Mocha.describe("Record_rest_test", () => { + Mocha.test("let binding captures record rest value", () => { + let rest = ((({name, ...__rest}) => __rest))({ + name: "test", + version: "1.0", + debug: true + }); + Test_utils.eq("File \"record_rest_test.res\", line 83, characters 7-14", "test", "test"); + Test_utils.eq("File \"record_rest_test.res\", line 84, characters 7-14", rest, { + version: "1.0", + debug: true + }); + }); + Mocha.test("match arm returns the named field and the rest record", () => Test_utils.eq("File \"record_rest_test.res\", line 89, characters 6-13", describeConfig({ + name: "match", + version: "2.0", + debug: false + }), [ + "match", + { + version: "2.0", + debug: false + } + ])); + Mocha.test("function parameter destructuring keeps the named field", () => Test_utils.eq("File \"record_rest_test.res\", line 96, characters 7-14", getName({ + name: "param", version: "3.0", debug: true - } + }), "param")); + Mocha.test("optional overlap keeps the remaining fields in the rest object", () => { + let onClick = () => {}; + let rest = extractClassName({ + className: "btn", + style: "bold", + onClick: onClick + }); + Test_utils.eq("File \"record_rest_test.res\", line 102, characters 7-14", rest, { + style: "bold", + onClick: onClick + }); + }); + Mocha.test("polymorphic rest captures the value field", () => { + let intRest = ((({id, ...__rest}) => __rest))({ + id: "1", + value: 42 + }); + Test_utils.eq("File \"record_rest_test.res\", line 107, characters 7-14", "1", "1"); + Test_utils.eq("File \"record_rest_test.res\", line 108, characters 7-14", intRest, { + value: 42 + }); + Test_utils.eq("File \"record_rest_test.res\", line 109, characters 7-14", ((({id, ...__rest}) => __rest))({ + id: "2", + value: "hello" + }), { + value: "hello" + }); + }); + Mocha.test("tuple nested record rest is initialized", () => Test_utils.eq("File \"record_rest_test.res\", line 114, characters 6-13", getTupleRest([ + { + name: "tuple", + version: "4.0", + debug: false + }, + 1 + ]), { + version: "4.0", + debug: false + })); + Mocha.test("variant payload rest works through the or-pattern path", () => { + Test_utils.eq("File \"record_rest_test.res\", line 122, characters 6-13", getWrappedRest({ + TAG: "Wrap", + _0: { + name: "wrapped", + version: "5.0", + debug: true + } + }), { + version: "5.0", + debug: true + }); + Test_utils.eq("File \"record_rest_test.res\", line 127, characters 6-13", getWrappedRest({ + TAG: "Mirror", + _0: { + name: "mirror", + version: "6.0", + debug: false + } + }), { + version: "6.0", + debug: false + }); + }); + Mocha.test("inline record variant rest removes the runtime tag field", () => { + Test_utils.eq("File \"record_rest_test.res\", line 135, characters 6-13", getInlineWrappedRest({ + TAG: "InlineWrap", + name: "inline", + version: "7.0", + debug: true + }), { + version: "7.0", + debug: true + }); + Test_utils.eq("File \"record_rest_test.res\", line 140, characters 6-13", getInlineWrappedRest({ + TAG: "InlineMirror", + name: "inlineMirror", + version: "8.0", + debug: false + }), { + version: "8.0", + debug: false + }); + }); + Mocha.test("inline record variant rest removes a custom runtime tag field", () => { + Test_utils.eq("File \"record_rest_test.res\", line 148, characters 6-13", getCustomTaggedInlineWrappedRest({ + kind: "CustomInlineWrap", + name: "customInline", + version: "9.0", + debug: true + }), { + version: "9.0", + debug: true + }); + Test_utils.eq("File \"record_rest_test.res\", line 155, characters 6-13", getCustomTaggedInlineWrappedRest({ + kind: "CustomInlineMirror", + name: "customInlineMirror", + version: "10.0", + debug: false + }), { + version: "10.0", + debug: false + }); + }); }); -let name = "test"; - -let id = "1"; - export { - rest, - name, - describe, + describeConfig, getName, extractClassName, - intRest, - id, getValue, getTupleRest, - tupleRest, getWrappedRest, - wrappedRest, + getInlineWrappedRest, + getCustomTaggedInlineWrappedRest, } -/* tupleRest Not a pure module */ +/* Not a pure module */ diff --git a/tests/tests/src/record_rest_test.res b/tests/tests/src/record_rest_test.res index 73bc8b1c531..57007d85be8 100644 --- a/tests/tests/src/record_rest_test.res +++ b/tests/tests/src/record_rest_test.res @@ -1,3 +1,6 @@ +open Mocha +open Test_utils + type config = { name: string, version: string, @@ -9,20 +12,13 @@ type subConfig = { debug: bool, } -// Basic rest pattern in let binding -let {name, ...subConfig as rest} = ({name: "test", version: "1.0", debug: true}: config) -let _ = (name, rest) - -// Rest pattern in match arm -let describe = (c: config) => +let describeConfig = (c: config) => switch c { | {name, ...subConfig as rest} => (name, rest) } -// Rest pattern in function parameter let getName = ({name, ...subConfig as _rest}: config) => name -// Optional field overlap: className is in both explicit (as optional) and rest type type fullProps = { className?: string, style?: string, @@ -35,12 +31,8 @@ type baseProps = { onClick: unit => unit, } -let extractClassName = ({?className, ...baseProps as rest}: fullProps) => { - let _ = className - rest -} +let extractClassName = ({className: ?_, ...baseProps as rest}: fullProps) => rest -// Polymorphic rest type type container<'a> = { id: string, value: 'a, @@ -50,26 +42,121 @@ type valueContainer<'a> = { value: 'a, } -let {id, ...valueContainer as intRest} = ({id: "1", value: 42}: container) -let _ = (id, intRest) - -// Polymorphic rest in function parameter let getValue = ({id: _, ...valueContainer<'a> as rest}: container<'a>) => rest type wrapped = | Wrap(config) | Mirror(config) -// Nested record rest in a tuple pattern let getTupleRest = (({name: _, ...subConfig as rest}, _): (config, int)) => rest -let tupleRest = getTupleRest((({name: "tuple", version: "2.0", debug: false}: config), 1)) - -// Nested record rest in constructor and or-pattern matches let getWrappedRest = wrapped => switch wrapped { | Wrap({name: _, ...subConfig as rest}) | Mirror({name: _, ...subConfig as rest}) => rest } -let wrappedRest = getWrappedRest(Wrap({name: "wrapped", version: "3.0", debug: true})) +type inlineWrapped = + | InlineWrap({name: string, version: string, debug: bool}) + | InlineMirror({name: string, version: string, debug: bool}) + +let getInlineWrappedRest = wrapped => + switch wrapped { + | InlineWrap({name: _, ...subConfig as rest}) + | InlineMirror({name: _, ...subConfig as rest}) => rest + } + +@tag("kind") +type customTaggedInlineWrapped = + | CustomInlineWrap({name: string, version: string, debug: bool}) + | CustomInlineMirror({name: string, version: string, debug: bool}) + +let getCustomTaggedInlineWrappedRest = wrapped => + switch wrapped { + | CustomInlineWrap({name: _, ...subConfig as rest}) + | CustomInlineMirror({name: _, ...subConfig as rest}) => rest + } + +describe(__MODULE__, () => { + test("let binding captures record rest value", () => { + let {name, ...subConfig as rest} = ({name: "test", version: "1.0", debug: true}: config) + eq(__LOC__, name, "test") + eq(__LOC__, rest, {version: "1.0", debug: true}) + }) + + test("match arm returns the named field and the rest record", () => { + eq( + __LOC__, + describeConfig({name: "match", version: "2.0", debug: false}), + ("match", {version: "2.0", debug: false}), + ) + }) + + test("function parameter destructuring keeps the named field", () => { + eq(__LOC__, getName({name: "param", version: "3.0", debug: true}), "param") + }) + + test("optional overlap keeps the remaining fields in the rest object", () => { + let onClick = () => () + let rest = extractClassName({className: "btn", style: "bold", onClick}) + eq(__LOC__, rest, {style: "bold", onClick}) + }) + + test("polymorphic rest captures the value field", () => { + let {id, ...valueContainer as intRest} = ({id: "1", value: 42}: container) + eq(__LOC__, id, "1") + eq(__LOC__, intRest, {value: 42}) + eq(__LOC__, getValue({id: "2", value: "hello"}), {value: "hello"}) + }) + + test("tuple nested record rest is initialized", () => { + eq( + __LOC__, + getTupleRest((({name: "tuple", version: "4.0", debug: false}: config), 1)), + {version: "4.0", debug: false}, + ) + }) + + test("variant payload rest works through the or-pattern path", () => { + eq( + __LOC__, + getWrappedRest(Wrap({name: "wrapped", version: "5.0", debug: true})), + {version: "5.0", debug: true}, + ) + eq( + __LOC__, + getWrappedRest(Mirror({name: "mirror", version: "6.0", debug: false})), + {version: "6.0", debug: false}, + ) + }) + + test("inline record variant rest removes the runtime tag field", () => { + eq( + __LOC__, + getInlineWrappedRest(InlineWrap({name: "inline", version: "7.0", debug: true})), + {version: "7.0", debug: true}, + ) + eq( + __LOC__, + getInlineWrappedRest(InlineMirror({name: "inlineMirror", version: "8.0", debug: false})), + {version: "8.0", debug: false}, + ) + }) + + test("inline record variant rest removes a custom runtime tag field", () => { + eq( + __LOC__, + getCustomTaggedInlineWrappedRest( + CustomInlineWrap({name: "customInline", version: "9.0", debug: true}), + ), + {version: "9.0", debug: true}, + ) + eq( + __LOC__, + getCustomTaggedInlineWrappedRest( + CustomInlineMirror({name: "customInlineMirror", version: "10.0", debug: false}), + ), + {version: "10.0", debug: false}, + ) + }) +}) From 42c6f9c51b85869e7e16f754a8eafcbbbb1edee0 Mon Sep 17 00:00:00 2001 From: tsnobip Date: Wed, 1 Apr 2026 15:52:22 +0200 Subject: [PATCH 12/22] check rest field types, fix matching & invalid field identifier --- compiler/core/lam_compile_primitive.ml | 20 +- compiler/ml/matching.ml | 8 +- compiler/ml/typecore.ml | 198 ++++++++++-------- ...cord_rest_field_type_mismatch.res.expected | 11 + .../record_rest_field_type_mismatch.res | 4 + tests/tests/src/record_rest_test.mjs | 87 +++++--- tests/tests/src/record_rest_test.res | 37 ++++ .../src/expected/ZRecordRest.res.jsout | 2 +- 8 files changed, 254 insertions(+), 113 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/record_rest_field_type_mismatch.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/record_rest_field_type_mismatch.res diff --git a/compiler/core/lam_compile_primitive.ml b/compiler/core/lam_compile_primitive.ml index 5c1f131f958..499619e057e 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -612,10 +612,22 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) | Precord_spread_new excluded -> ( match args with | [e1] -> - (* Generate: (({field1, field2, ...rest}) => rest)(source) - This uses JS destructuring to cleanly extract the rest *) - let excluded_str = String.concat ", " excluded in - let code = Printf.sprintf "(({%s, ...__rest}) => __rest)" excluded_str in + (* Generate: (({field1: __unused0, ...__rest}) => __rest)(source) + This uses JS destructuring to cleanly extract the rest while + safely handling quoted property names and the empty-exclusion case. *) + let excluded_bindings = + List.mapi + (fun i field -> + let field = Js_dump_property.property_key (Js_op.Lit field) in + Printf.sprintf "%s: __unused%d" field i) + excluded + in + let destructured = + match excluded_bindings with + | [] -> "...__rest" + | _ -> String.concat ", " excluded_bindings ^ ", ...__rest" + in + let code = Printf.sprintf "(({%s}) => __rest)" destructured in E.call ~info:{arity = Full; call_info = Call_na; call_transformed_jsx = false} (E.raw_js_code (Exp (Js_function {arity = 1; arrow = true})) code) diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index ac7b952aeac..53a78238182 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -564,7 +564,13 @@ let simplify_cases args cls = | Tpat_any -> cl :: simplify rem | Tpat_alias (p, id, _) -> simplify ((p :: patl, bind Alias id arg action) :: rem) - | Tpat_record ([], _, _rest) -> (omega :: patl, action) :: simplify rem + | Tpat_record ([], _, rest) -> + let action = + match rest with + | None -> action + | Some rest -> bind_record_rest pat.pat_loc arg rest action + in + (omega :: patl, action) :: simplify rem | Tpat_record (lbls, closed, rest) -> let all_lbls = all_record_args lbls in let full_pat = diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 0cbdee25d3c..c8ccb73c72e 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -1594,9 +1594,9 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp let rest_path, rest_decl = Typetexp.find_type !env rest_type_lid.loc rest_type_lid.txt in - let rest_labels = - match rest_decl with - | {type_kind = Type_record (labels, _)} -> labels + let rest_decl = + match rest_decl.type_kind with + | Type_record _ -> instance_declaration rest_decl | _ -> raise (Error @@ -1608,6 +1608,77 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp let explicit_fields = List.map (fun (_, label, _, _) -> label.lbl_name) lbl_pat_list in + let rest_type_args = + match rest_type_args_syntax with + | [] -> List.map (fun _ -> newvar ()) rest_decl.type_params + | args -> + let n_args = List.length args in + let n_params = List.length rest_decl.type_params in + if n_args <> n_params then + raise + (Typetexp.Error + ( rest_type_lid.loc, + !env, + Typetexp.Type_arity_mismatch + (rest_type_lid.txt, n_params, n_args) )); + List.map + (fun sty -> + let cty, force = + Typetexp.transl_simple_type_delayed !env sty + in + pattern_force := force :: !pattern_force; + cty.ctyp_type) + args + in + let rest_type_expr = + newgenty (Tconstr (rest_path, rest_type_args, ref Mnil)) + in + List.iter2 + (fun param arg -> unify_pat_types rest_type_lid.loc !env param arg) + rest_decl.type_params rest_type_args; + let source_fields, source_repr = + match + try + let _, _, source_decl = + extract_concrete_typedecl !env record_ty + in + let source_decl = instance_declaration source_decl in + let source_type_args = + match expand_head !env record_ty with + | {desc = Tconstr (_, args, _)} -> args + | _ -> assert false + in + Some (source_decl, source_type_args) + with Not_found -> None + with + | Some (source_decl, source_type_args) -> ( + List.iter2 + (fun param arg -> unify_pat_types loc !env param arg) + source_decl.type_params source_type_args; + match source_decl.type_kind with + | Type_record (fields, repr) -> + ( List.map + (fun (l : Types.label_declaration) -> + (Ident.name l.ld_id, l.ld_type)) + fields, + repr ) + | _ -> assert false) + | None -> ( + unify_pat_types rest_type_lid.loc !env record_ty rest_type_expr; + match rest_decl.type_kind with + | Type_record (fields, repr) -> + ( List.map + (fun (l : Types.label_declaration) -> + (Ident.name l.ld_id, l.ld_type)) + fields, + repr ) + | _ -> assert false) + in + let rest_labels = + match rest_decl.type_kind with + | Type_record (labels, _) -> labels + | _ -> assert false + in (* Get explicit optional fields *) let explicit_optional_fields = List.filter_map @@ -1616,20 +1687,17 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp lbl_pat_list in let runtime_excluded_fields = - match lbl_pat_list with - | (_, label1, _, _) :: _ -> ( - match label1.lbl_repres with - | Record_inlined {attrs; _} - when not (Ast_untagged_variants.process_untagged attrs) -> - let tag_name = - match Ast_untagged_variants.process_tag_name attrs with - | Some s -> s - | None -> "TAG" - in - if List.mem tag_name explicit_fields then explicit_fields - else tag_name :: explicit_fields - | _ -> explicit_fields) - | [] -> explicit_fields + match source_repr with + | Record_inlined {attrs; _} + when not (Ast_untagged_variants.process_untagged attrs) -> + let tag_name = + match Ast_untagged_variants.process_tag_name attrs with + | Some s -> s + | None -> "TAG" + in + if List.mem tag_name explicit_fields then explicit_fields + else tag_name :: explicit_fields + | _ -> explicit_fields in (* Get rest field names *) let rest_field_names = @@ -1653,47 +1721,36 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp Record_rest_field_not_optional (not_optional, rest_type_lid.txt) )); (* Validate: all source fields must be in explicit or rest *) - (match lbl_pat_list with - | (_, label1, _, _) :: _ -> - let all_source = label1.lbl_all in - let missing = - Array.to_list all_source - |> List.filter_map (fun source_label -> - let name = source_label.lbl_name in - if - (not (List.mem name explicit_fields)) - && not (List.mem name rest_field_names) - then Some name - else None) - in - if missing <> [] then - raise - (Error - ( rest_pat.ppat_loc, - !env, - Record_rest_field_missing (missing, rest_type_lid.txt) )) - | [] -> ()); - (* Validate: rest type fields must all exist in source *) - (match lbl_pat_list with - | (_, label1, _, _) :: _ -> - let all_source = label1.lbl_all in - let source_field_names = - Array.to_list (Array.map (fun l -> l.lbl_name) all_source) - in - List.iter - (fun (rest_label : Types.label_declaration) -> - if - not - (List.mem (Ident.name rest_label.ld_id) source_field_names) - then - raise - (Error - ( rest_type_lid.loc, - !env, - Record_rest_extra_field - (Ident.name rest_label.ld_id, rest_type_lid.txt) ))) - rest_labels - | [] -> ()); + let source_field_names = List.map fst source_fields in + let missing = + List.filter + (fun source_field -> + (not (List.mem source_field explicit_fields)) + && not (List.mem source_field rest_field_names)) + source_field_names + in + if missing <> [] then + raise + (Error + ( rest_pat.ppat_loc, + !env, + Record_rest_field_missing (missing, rest_type_lid.txt) )); + (* Validate: rest type fields must all exist in source and use compatible types *) + List.iter + (fun (rest_label : Types.label_declaration) -> + let rest_field = Ident.name rest_label.ld_id in + match List.assoc_opt rest_field source_fields with + | None -> + raise + (Error + ( rest_type_lid.loc, + !env, + Record_rest_extra_field (rest_field, rest_type_lid.txt) + )) + | Some source_type -> + unify_pat_types rest_type_lid.loc !env rest_label.ld_type + source_type) + rest_labels; (* Warn if all rest fields are already explicit — the rest record will be empty *) if rest_field_names <> [] @@ -1703,31 +1760,6 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp then Location.prerr_warning rest_pat.ppat_loc Warnings.Bs_record_rest_empty; - let rest_type_args = - match rest_type_args_syntax with - | [] -> List.map (fun _ -> newvar ()) rest_decl.type_params - | args -> - let n_args = List.length args in - let n_params = List.length rest_decl.type_params in - if n_args <> n_params then - raise - (Typetexp.Error - ( rest_type_lid.loc, - !env, - Typetexp.Type_arity_mismatch - (rest_type_lid.txt, n_params, n_args) )); - List.map - (fun sty -> - let cty, force = - Typetexp.transl_simple_type_delayed !env sty - in - pattern_force := force :: !pattern_force; - cty.ctyp_type) - args - in - let rest_type_expr = - newgenty (Tconstr (rest_path, rest_type_args, ref Mnil)) - in let rest_ident = enter_variable rest_pat.ppat_loc rest_name rest_type_expr in diff --git a/tests/build_tests/super_errors/expected/record_rest_field_type_mismatch.res.expected b/tests/build_tests/super_errors/expected/record_rest_field_type_mismatch.res.expected new file mode 100644 index 00000000000..4454b137c57 --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_rest_field_type_mismatch.res.expected @@ -0,0 +1,11 @@ + + We've found a bug for you! + /.../fixtures/record_rest_field_type_mismatch.res:4:12-16 + + 2 │ type wrong = {b: int} + 3 │ + 4 │ let {a, ...wrong as rest} = ({a: 1, b: "x"}: source) + 5 │ + + This pattern matches values of type int + but a pattern was expected which matches values of type string \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/record_rest_field_type_mismatch.res b/tests/build_tests/super_errors/fixtures/record_rest_field_type_mismatch.res new file mode 100644 index 00000000000..d42513e6aff --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/record_rest_field_type_mismatch.res @@ -0,0 +1,4 @@ +type source = {a: int, b: string} +type wrong = {b: int} + +let {a, ...wrong as rest} = ({a: 1, b: "x"}: source) diff --git a/tests/tests/src/record_rest_test.mjs b/tests/tests/src/record_rest_test.mjs index 1ee94ebf2fc..d08838c14b6 100644 --- a/tests/tests/src/record_rest_test.mjs +++ b/tests/tests/src/record_rest_test.mjs @@ -4,7 +4,7 @@ import * as Mocha from "mocha"; import * as Test_utils from "./test_utils.mjs"; function describeConfig(c) { - let rest = ((({name, ...__rest}) => __rest))(c); + let rest = ((({name: __unused0, ...__rest}) => __rest))(c); return [ c.name, rest @@ -15,44 +15,52 @@ function getName(param) { return param.name; } +function getWholeConfig(param) { + return ((({...__rest}) => __rest))(param); +} + function extractClassName(param) { - return ((({className, ...__rest}) => __rest))(param); + return ((({className: __unused0, ...__rest}) => __rest))(param); } function getValue(param) { - return ((({id, ...__rest}) => __rest))(param); + return ((({id: __unused0, ...__rest}) => __rest))(param); } function getTupleRest(param) { - return ((({name, ...__rest}) => __rest))(param[0]); + return ((({name: __unused0, ...__rest}) => __rest))(param[0]); } function getWrappedRest(wrapped) { - return ((({name, ...__rest}) => __rest))(wrapped._0); + return ((({name: __unused0, ...__rest}) => __rest))(wrapped._0); } function getInlineWrappedRest(wrapped) { - return ((({TAG, name, ...__rest}) => __rest))(wrapped); + return ((({TAG: __unused0, name: __unused1, ...__rest}) => __rest))(wrapped); } function getCustomTaggedInlineWrappedRest(wrapped) { - return ((({kind, name, ...__rest}) => __rest))(wrapped); + return ((({kind: __unused0, name: __unused1, ...__rest}) => __rest))(wrapped); +} + +function getDashedTaggedInlineWrappedRest(wrapped) { + return ((({"custom-tag": __unused0, name: __unused1, ...__rest}) => __rest))(wrapped); } Mocha.describe("Record_rest_test", () => { Mocha.test("let binding captures record rest value", () => { - let rest = ((({name, ...__rest}) => __rest))({ + let rest = ((({name: __unused0, ...__rest}) => __rest))({ name: "test", version: "1.0", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 83, characters 7-14", "test", "test"); - Test_utils.eq("File \"record_rest_test.res\", line 84, characters 7-14", rest, { + Test_utils.eq("File \"record_rest_test.res\", line 95, characters 7-14", "test", "test"); + Test_utils.eq("File \"record_rest_test.res\", line 96, characters 7-14", rest, { version: "1.0", debug: true }); }); - Mocha.test("match arm returns the named field and the rest record", () => Test_utils.eq("File \"record_rest_test.res\", line 89, characters 6-13", describeConfig({ + Mocha.test("match arm returns the named field and the rest record", () => Test_utils.eq("File \"record_rest_test.res\", line 101, characters 6-13", describeConfig({ name: "match", version: "2.0", debug: false @@ -63,11 +71,20 @@ Mocha.describe("Record_rest_test", () => { debug: false } ])); - Mocha.test("function parameter destructuring keeps the named field", () => Test_utils.eq("File \"record_rest_test.res\", line 96, characters 7-14", getName({ + Mocha.test("function parameter destructuring keeps the named field", () => Test_utils.eq("File \"record_rest_test.res\", line 108, characters 7-14", getName({ name: "param", version: "3.0", debug: true }), "param")); + Mocha.test("empty-field rest pattern still binds the whole record", () => Test_utils.eq("File \"record_rest_test.res\", line 113, characters 6-13", ((({...__rest}) => __rest))({ + name: "whole", + version: "3.5", + debug: false + }), { + name: "whole", + version: "3.5", + debug: false + })); Mocha.test("optional overlap keeps the remaining fields in the rest object", () => { let onClick = () => {}; let rest = extractClassName({ @@ -75,28 +92,28 @@ Mocha.describe("Record_rest_test", () => { style: "bold", onClick: onClick }); - Test_utils.eq("File \"record_rest_test.res\", line 102, characters 7-14", rest, { + Test_utils.eq("File \"record_rest_test.res\", line 122, characters 7-14", rest, { style: "bold", onClick: onClick }); }); Mocha.test("polymorphic rest captures the value field", () => { - let intRest = ((({id, ...__rest}) => __rest))({ + let intRest = ((({id: __unused0, ...__rest}) => __rest))({ id: "1", value: 42 }); - Test_utils.eq("File \"record_rest_test.res\", line 107, characters 7-14", "1", "1"); - Test_utils.eq("File \"record_rest_test.res\", line 108, characters 7-14", intRest, { + Test_utils.eq("File \"record_rest_test.res\", line 127, characters 7-14", "1", "1"); + Test_utils.eq("File \"record_rest_test.res\", line 128, characters 7-14", intRest, { value: 42 }); - Test_utils.eq("File \"record_rest_test.res\", line 109, characters 7-14", ((({id, ...__rest}) => __rest))({ + Test_utils.eq("File \"record_rest_test.res\", line 129, characters 7-14", ((({id: __unused0, ...__rest}) => __rest))({ id: "2", value: "hello" }), { value: "hello" }); }); - Mocha.test("tuple nested record rest is initialized", () => Test_utils.eq("File \"record_rest_test.res\", line 114, characters 6-13", getTupleRest([ + Mocha.test("tuple nested record rest is initialized", () => Test_utils.eq("File \"record_rest_test.res\", line 134, characters 6-13", getTupleRest([ { name: "tuple", version: "4.0", @@ -108,7 +125,7 @@ Mocha.describe("Record_rest_test", () => { debug: false })); Mocha.test("variant payload rest works through the or-pattern path", () => { - Test_utils.eq("File \"record_rest_test.res\", line 122, characters 6-13", getWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 142, characters 6-13", getWrappedRest({ TAG: "Wrap", _0: { name: "wrapped", @@ -119,7 +136,7 @@ Mocha.describe("Record_rest_test", () => { version: "5.0", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 127, characters 6-13", getWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 147, characters 6-13", getWrappedRest({ TAG: "Mirror", _0: { name: "mirror", @@ -132,7 +149,7 @@ Mocha.describe("Record_rest_test", () => { }); }); Mocha.test("inline record variant rest removes the runtime tag field", () => { - Test_utils.eq("File \"record_rest_test.res\", line 135, characters 6-13", getInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 155, characters 6-13", getInlineWrappedRest({ TAG: "InlineWrap", name: "inline", version: "7.0", @@ -141,7 +158,7 @@ Mocha.describe("Record_rest_test", () => { version: "7.0", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 140, characters 6-13", getInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 160, characters 6-13", getInlineWrappedRest({ TAG: "InlineMirror", name: "inlineMirror", version: "8.0", @@ -152,7 +169,7 @@ Mocha.describe("Record_rest_test", () => { }); }); Mocha.test("inline record variant rest removes a custom runtime tag field", () => { - Test_utils.eq("File \"record_rest_test.res\", line 148, characters 6-13", getCustomTaggedInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 168, characters 6-13", getCustomTaggedInlineWrappedRest({ kind: "CustomInlineWrap", name: "customInline", version: "9.0", @@ -161,7 +178,7 @@ Mocha.describe("Record_rest_test", () => { version: "9.0", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 155, characters 6-13", getCustomTaggedInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 175, characters 6-13", getCustomTaggedInlineWrappedRest({ kind: "CustomInlineMirror", name: "customInlineMirror", version: "10.0", @@ -171,16 +188,38 @@ Mocha.describe("Record_rest_test", () => { debug: false }); }); + Mocha.test("inline record rest works with a non-identifier custom tag name", () => { + Test_utils.eq("File \"record_rest_test.res\", line 185, characters 6-13", getDashedTaggedInlineWrappedRest({ + "custom-tag": "DashedInlineWrap", + name: "dashedInline", + version: "11.0", + debug: true + }), { + version: "11.0", + debug: true + }); + Test_utils.eq("File \"record_rest_test.res\", line 192, characters 6-13", getDashedTaggedInlineWrappedRest({ + "custom-tag": "DashedInlineMirror", + name: "dashedInlineMirror", + version: "12.0", + debug: false + }), { + version: "12.0", + debug: false + }); + }); }); export { describeConfig, getName, + getWholeConfig, extractClassName, getValue, getTupleRest, getWrappedRest, getInlineWrappedRest, getCustomTaggedInlineWrappedRest, + getDashedTaggedInlineWrappedRest, } /* Not a pure module */ diff --git a/tests/tests/src/record_rest_test.res b/tests/tests/src/record_rest_test.res index 57007d85be8..fa014dd561b 100644 --- a/tests/tests/src/record_rest_test.res +++ b/tests/tests/src/record_rest_test.res @@ -18,6 +18,7 @@ let describeConfig = (c: config) => } let getName = ({name, ...subConfig as _rest}: config) => name +let getWholeConfig = ({...config as rest}: config) => rest type fullProps = { className?: string, @@ -77,6 +78,17 @@ let getCustomTaggedInlineWrappedRest = wrapped => | CustomInlineMirror({name: _, ...subConfig as rest}) => rest } +@tag("custom-tag") +type dashedTaggedInlineWrapped = + | DashedInlineWrap({name: string, version: string, debug: bool}) + | DashedInlineMirror({name: string, version: string, debug: bool}) + +let getDashedTaggedInlineWrappedRest = wrapped => + switch wrapped { + | DashedInlineWrap({name: _, ...subConfig as rest}) + | DashedInlineMirror({name: _, ...subConfig as rest}) => rest + } + describe(__MODULE__, () => { test("let binding captures record rest value", () => { let {name, ...subConfig as rest} = ({name: "test", version: "1.0", debug: true}: config) @@ -96,6 +108,14 @@ describe(__MODULE__, () => { eq(__LOC__, getName({name: "param", version: "3.0", debug: true}), "param") }) + test("empty-field rest pattern still binds the whole record", () => { + eq( + __LOC__, + getWholeConfig({name: "whole", version: "3.5", debug: false}), + {name: "whole", version: "3.5", debug: false}, + ) + }) + test("optional overlap keeps the remaining fields in the rest object", () => { let onClick = () => () let rest = extractClassName({className: "btn", style: "bold", onClick}) @@ -159,4 +179,21 @@ describe(__MODULE__, () => { {version: "10.0", debug: false}, ) }) + + test("inline record rest works with a non-identifier custom tag name", () => { + eq( + __LOC__, + getDashedTaggedInlineWrappedRest( + DashedInlineWrap({name: "dashedInline", version: "11.0", debug: true}), + ), + {version: "11.0", debug: true}, + ) + eq( + __LOC__, + getDashedTaggedInlineWrappedRest( + DashedInlineMirror({name: "dashedInlineMirror", version: "12.0", debug: false}), + ), + {version: "12.0", debug: false}, + ) + }) }) diff --git a/tests/tools_tests/src/expected/ZRecordRest.res.jsout b/tests/tools_tests/src/expected/ZRecordRest.res.jsout index acc2f53a8e2..d5248cb5beb 100644 --- a/tests/tools_tests/src/expected/ZRecordRest.res.jsout +++ b/tests/tools_tests/src/expected/ZRecordRest.res.jsout @@ -3,7 +3,7 @@ function extract(param) { - let rest = ((({name, ...__rest}) => __rest))(param); + let rest = ((({name: __unused0, ...__rest}) => __rest))(param); return [ param.name, rest From 68e0ebbc0ed8e8c6a3d28f7cb5902fa7780f118a Mon Sep 17 00:00:00 2001 From: tsnobip Date: Wed, 1 Apr 2026 17:24:38 +0200 Subject: [PATCH 13/22] fix rest of private type and analysis --- analysis/src/process_cmt.ml | 23 +++++++++++++++++-- analysis/src/process_extra.ml | 22 +++++++++++++----- compiler/ml/matching.ml | 2 +- compiler/ml/typecore.ml | 3 +++ compiler/ml/typedtree.ml | 5 ++-- compiler/ml/typedtree.mli | 1 + compiler/syntax/src/res_core.ml | 2 +- tests/analysis_tests/tests/src/RecordRest.res | 9 ++++++++ .../tests/src/expected/RecordRest.res.txt | 2 ++ .../record_rest_private_type.res.expected | 10 ++++++++ .../fixtures/record_rest_private_type.res | 9 ++++++++ 11 files changed, 75 insertions(+), 13 deletions(-) create mode 100644 tests/analysis_tests/tests/src/RecordRest.res create mode 100644 tests/analysis_tests/tests/src/expected/RecordRest.res.txt create mode 100644 tests/build_tests/super_errors/expected/record_rest_private_type.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/record_rest_private_type.res diff --git a/analysis/src/process_cmt.ml b/analysis/src/process_cmt.ml index ab7aa7d46f7..81e9a6817a6 100644 --- a/analysis/src/process_cmt.ml +++ b/analysis/src/process_cmt.ml @@ -517,8 +517,27 @@ let rec for_structure_item ~(env : Shared_types.Env.t) ~(exported : Exported.t) | Tpat_tuple pats | Tpat_array pats | Tpat_construct (_, _, pats) -> pats |> List.iter (fun p -> handle_pattern [] p) | Tpat_or (p, _, _) -> handle_pattern [] p - | Tpat_record (items, _, _rest) -> - items |> List.iter (fun (_, _, p, _) -> handle_pattern [] p) + | Tpat_record (record_items, _, rest) -> ( + record_items |> List.iter (fun (_, _, p, _) -> handle_pattern [] p); + match rest with + | None -> () + | Some rest -> + let declared = + add_declared ~name:rest.rest_name + ~stamp:(Ident.binding_time rest.rest_ident) + ~env ~extent:rest.rest_name.loc ~item:rest.rest_type [] + (Exported.add exported Exported.Value) + Stamps.add_value + in + items := + { + Module.kind = Module.Value declared.item; + name = declared.name.txt; + docstring = declared.docstring; + deprecated = declared.deprecated; + loc = declared.extent_loc; + } + :: !items) | Tpat_variant (_, Some p, _) -> handle_pattern [] p | Tpat_variant (_, None, _) | Tpat_any | Tpat_constant _ -> () in diff --git a/analysis/src/process_extra.ml b/analysis/src/process_extra.ml index c2a7bd24508..2cd5782b578 100644 --- a/analysis/src/process_extra.ml +++ b/analysis/src/process_extra.ml @@ -378,22 +378,32 @@ let pat ~(file : File.t) ~env ~extra (iter : Tast_iterator.iterator) | Tpackage (path, _, _) -> Some path | _ -> None in - let add_for_pattern stamp name = + let add_for_declared_pattern ~stamp ~name ~extent ~item ~attributes = if Stamps.find_value file.stamps stamp = None then ( let declared = Process_attributes.new_declared ~name ~stamp ~module_path:NotVisible - ~extent:pattern.pat_loc ~item:pattern.pat_type false - pattern.pat_attributes + ~extent ~item false attributes in Stamps.add_value file.stamps stamp declared; add_reference ~extra stamp name.loc; add_loc_item extra name.loc - (Typed (name.txt, pattern.pat_type, Definition (stamp, Value)))) + (Typed (name.txt, item, Definition (stamp, Value)))) + in + let add_for_pattern stamp name = + add_for_declared_pattern ~stamp ~name ~extent:pattern.pat_loc + ~item:pattern.pat_type ~attributes:pattern.pat_attributes in (* Log.log("Entering pattern " ++ Utils.showLocation(pat_loc)); *) (match pattern.pat_desc with - | Tpat_record (items, _, _rest) -> - add_for_record ~env ~extra ~record_type:pattern.pat_type items + | Tpat_record (items, _, rest) -> ( + add_for_record ~env ~extra ~record_type:pattern.pat_type items; + match rest with + | None -> () + | Some rest -> + add_for_declared_pattern + ~stamp:(Ident.binding_time rest.rest_ident) + ~name:rest.rest_name ~extent:rest.rest_name.loc ~item:rest.rest_type + ~attributes:pattern.pat_attributes) | Tpat_construct (lident, constructor, _) -> add_for_constructor ~env ~extra pattern.pat_type lident constructor | Tpat_alias (_inner, ident, name) -> ( diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index 53a78238182..61b6b0766ba 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -640,7 +640,7 @@ let rec extract_vars r p = let r = List.fold_left (fun r (_, _, p, _) -> extract_vars r p) r lpats in match rest with | None -> r - | Some rest -> IdentSet.add rest.rest_ident r) + | Some rest -> Ident_set.add rest.rest_ident r) | Tpat_construct (_, _, pats) -> List.fold_left extract_vars r pats | Tpat_array pats -> List.fold_left extract_vars r pats | Tpat_variant (_, Some p, _) -> extract_vars r p diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index c8ccb73c72e..3421de73075 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -1633,6 +1633,8 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp let rest_type_expr = newgenty (Tconstr (rest_path, rest_type_args, ref Mnil)) in + if rest_decl.type_private = Private then + raise (Error (rest_type_lid.loc, !env, Private_type rest_type_expr)); List.iter2 (fun param arg -> unify_pat_types rest_type_lid.loc !env param arg) rest_decl.type_params rest_type_args; @@ -1766,6 +1768,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp Some { Typedtree.rest_ident; + rest_name; rest_type = rest_type_expr; rest_path; rest_labels; diff --git a/compiler/ml/typedtree.ml b/compiler/ml/typedtree.ml index 5557c2beefe..74813efe3cb 100644 --- a/compiler/ml/typedtree.ml +++ b/compiler/ml/typedtree.ml @@ -37,6 +37,7 @@ type pattern = { and record_pat_rest = { rest_ident: Ident.t; + rest_name: string loc; rest_type: type_expr; rest_path: Path.t; rest_labels: Types.label_declaration list; @@ -463,9 +464,7 @@ let rec bound_idents pat = | Tpat_record (_, _, Some rest) -> (* Rest ident is added via enter_variable during type checking, but we also need it in bound_idents for Lambda compilation *) - idents := - (rest.rest_ident, Location.mknoloc (Ident.name rest.rest_ident)) - :: !idents; + idents := (rest.rest_ident, rest.rest_name) :: !idents; iter_pattern_desc bound_idents pat.pat_desc | d -> iter_pattern_desc bound_idents d diff --git a/compiler/ml/typedtree.mli b/compiler/ml/typedtree.mli index 3dbeb96d7f3..345badc805c 100644 --- a/compiler/ml/typedtree.mli +++ b/compiler/ml/typedtree.mli @@ -45,6 +45,7 @@ type pattern = { and record_pat_rest = { rest_ident: Ident.t; + rest_name: string loc; rest_type: type_expr; rest_path: Path.t; rest_labels: Types.label_declaration list; diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index 8b989be7b1c..3afb0cb5800 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -1624,7 +1624,7 @@ and parse_record_pattern ~attrs p = | None -> (fields, flag, Some rest_pat) | Some _ -> Parser.err ~start_pos:rest_pat.Parsetree.ppat_loc.loc_start p - (Diagnostics.message ErrorMessages.record_pattern_multiple_rest); + (Diagnostics.message Error_messages.record_pattern_multiple_rest); (fields, flag, rest)) | PatUnderscore -> (fields, flag, rest)) ([], flag, None) raw_fields diff --git a/tests/analysis_tests/tests/src/RecordRest.res b/tests/analysis_tests/tests/src/RecordRest.res new file mode 100644 index 00000000000..cca4d605c92 --- /dev/null +++ b/tests/analysis_tests/tests/src/RecordRest.res @@ -0,0 +1,9 @@ +type config = {name: string, version: string} +type subConfig = {version: string} + +let getVersion = (config: config) => + switch config { + | {name: _, ...subConfig as rest} => + rest.version +// ^def + } diff --git a/tests/analysis_tests/tests/src/expected/RecordRest.res.txt b/tests/analysis_tests/tests/src/expected/RecordRest.res.txt new file mode 100644 index 00000000000..1677d82115c --- /dev/null +++ b/tests/analysis_tests/tests/src/expected/RecordRest.res.txt @@ -0,0 +1,2 @@ +Definition src/RecordRest.res 6:4 +{"uri": "RecordRest.res", "range": {"start": {"line": 5, "character": 30}, "end": {"line": 5, "character": 34}}} diff --git a/tests/build_tests/super_errors/expected/record_rest_private_type.res.expected b/tests/build_tests/super_errors/expected/record_rest_private_type.res.expected new file mode 100644 index 00000000000..3058651a5cc --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_rest_private_type.res.expected @@ -0,0 +1,10 @@ + + We've found a bug for you! + /.../fixtures/record_rest_private_type.res:9:12-14 + + 7 │ type source = {a: int, b: string} + 8 │ + 9 │ let {a, ...M.t as rest} = ({a: 1, b: "x"}: source) + 10 │ + + Cannot create values of the private type M.t \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/record_rest_private_type.res b/tests/build_tests/super_errors/fixtures/record_rest_private_type.res new file mode 100644 index 00000000000..39ffbbf8c2f --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/record_rest_private_type.res @@ -0,0 +1,9 @@ +module M: { + type t = private {b: string} +} = { + type t = {b: string} +} + +type source = {a: int, b: string} + +let {a, ...M.t as rest} = ({a: 1, b: "x"}: source) From 83a70068c74b8c1ab1696a93e093d383f82ab1a7 Mon Sep 17 00:00:00 2001 From: tsnobip Date: Wed, 1 Apr 2026 23:09:05 +0200 Subject: [PATCH 14/22] use runtime field names for rest --- compiler/ml/typecore.ml | 68 +++++++++++++++-- compiler/ml/typecore.mli | 6 ++ ...t_field_runtime_name_mismatch.res.expected | 10 +++ ...ecord_rest_field_runtime_name_mismatch.res | 12 +++ tests/tests/src/record_rest_test.mjs | 74 ++++++++++++++----- tests/tests/src/record_rest_test.res | 54 ++++++++++++++ 6 files changed, 198 insertions(+), 26 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/record_rest_field_runtime_name_mismatch.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/record_rest_field_runtime_name_mismatch.res diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 3421de73075..ba9ff1020d1 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -102,6 +102,12 @@ type error = | Record_rest_field_not_optional of string list * Longident.t | Record_rest_field_missing of string list * Longident.t | Record_rest_extra_field of string * Longident.t + | Record_rest_field_runtime_name_mismatch of { + field: string; + rest_type: Longident.t; + source_runtime_name: string; + rest_runtime_name: string; + } exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -334,6 +340,15 @@ let extract_concrete_variant env ty = | p0, p, {type_kind = Type_open} -> (p0, p, []) | _ -> raise Not_found +let runtime_label_name name attrs = + Ext_list.find_def attrs Lambda.find_name name + +let runtime_label_description_name (lbl : Types.label_description) = + runtime_label_name lbl.lbl_name lbl.lbl_attributes + +let runtime_label_declaration_name (lbl : Types.label_declaration) = + runtime_label_name (Ident.name lbl.ld_id) lbl.ld_attributes + let label_is_optional ld = ld.lbl_optional let check_optional_attr env ld optional loc = @@ -1608,6 +1623,11 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp let explicit_fields = List.map (fun (_, label, _, _) -> label.lbl_name) lbl_pat_list in + let explicit_runtime_fields = + List.map + (fun (_, label, _, _) -> runtime_label_description_name label) + lbl_pat_list + in let rest_type_args = match rest_type_args_syntax with | [] -> List.map (fun _ -> newvar ()) rest_decl.type_params @@ -1661,7 +1681,9 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp | Type_record (fields, repr) -> ( List.map (fun (l : Types.label_declaration) -> - (Ident.name l.ld_id, l.ld_type)) + ( Ident.name l.ld_id, + runtime_label_declaration_name l, + l.ld_type )) fields, repr ) | _ -> assert false) @@ -1671,7 +1693,9 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp | Type_record (fields, repr) -> ( List.map (fun (l : Types.label_declaration) -> - (Ident.name l.ld_id, l.ld_type)) + ( Ident.name l.ld_id, + runtime_label_declaration_name l, + l.ld_type )) fields, repr ) | _ -> assert false) @@ -1697,9 +1721,10 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp | Some s -> s | None -> "TAG" in - if List.mem tag_name explicit_fields then explicit_fields - else tag_name :: explicit_fields - | _ -> explicit_fields + if List.mem tag_name explicit_runtime_fields then + explicit_runtime_fields + else tag_name :: explicit_runtime_fields + | _ -> explicit_runtime_fields in (* Get rest field names *) let rest_field_names = @@ -1723,7 +1748,9 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp Record_rest_field_not_optional (not_optional, rest_type_lid.txt) )); (* Validate: all source fields must be in explicit or rest *) - let source_field_names = List.map fst source_fields in + let source_field_names = + List.map (fun (name, _, _) -> name) source_fields + in let missing = List.filter (fun source_field -> @@ -1741,7 +1768,13 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp List.iter (fun (rest_label : Types.label_declaration) -> let rest_field = Ident.name rest_label.ld_id in - match List.assoc_opt rest_field source_fields with + let rest_runtime_field = + runtime_label_declaration_name rest_label + in + match + Ext_list.find_first source_fields (fun (field, _, _) -> + field = rest_field) + with | None -> raise (Error @@ -1749,7 +1782,19 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp !env, Record_rest_extra_field (rest_field, rest_type_lid.txt) )) - | Some source_type -> + | Some (_, source_runtime_field, source_type) -> + if source_runtime_field <> rest_runtime_field then + raise + (Error + ( rest_type_lid.loc, + !env, + Record_rest_field_runtime_name_mismatch + { + field = rest_field; + rest_type = rest_type_lid.txt; + source_runtime_name = source_runtime_field; + rest_runtime_name = rest_runtime_field; + } )); unify_pat_types rest_type_lid.loc !env rest_label.ld_type source_type) rest_labels; @@ -5349,6 +5394,13 @@ let report_error env loc ppf error = "Field `%s` in the rest type `%a` does not exist in the source record \ type." field longident lid + | Record_rest_field_runtime_name_mismatch + {field; rest_type; source_runtime_name; rest_runtime_name} -> + fprintf ppf + "Field `%s` in the rest type `%a` has runtime representation `%s`, but \ + in the source record type it is `%s`. Runtime representations must \ + match." + field longident rest_type rest_runtime_name source_runtime_name let report_error env loc ppf err = Printtyp.wrap_printing_env env (fun () -> report_error env loc ppf err) diff --git a/compiler/ml/typecore.mli b/compiler/ml/typecore.mli index 7d1ac112903..03a878e302d 100644 --- a/compiler/ml/typecore.mli +++ b/compiler/ml/typecore.mli @@ -135,6 +135,12 @@ type error = | Record_rest_field_not_optional of string list * Longident.t | Record_rest_field_missing of string list * Longident.t | Record_rest_extra_field of string * Longident.t + | Record_rest_field_runtime_name_mismatch of { + field: string; + rest_type: Longident.t; + source_runtime_name: string; + rest_runtime_name: string; + } exception Error of Location.t * Env.t * error exception Error_forward of Location.error diff --git a/tests/build_tests/super_errors/expected/record_rest_field_runtime_name_mismatch.res.expected b/tests/build_tests/super_errors/expected/record_rest_field_runtime_name_mismatch.res.expected new file mode 100644 index 00000000000..8e1066345d2 --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_rest_field_runtime_name_mismatch.res.expected @@ -0,0 +1,10 @@ + + We've found a bug for you! + /.../fixtures/record_rest_field_runtime_name_mismatch.res:12:12-16 + + 10 │ } + 11 │ + 12 │ let {a, ...wrong as rest} = ({a: 1, b: "x"}: source) + 13 │ + + Field `b` in the rest type `wrong` has runtime representation `other-b`, but in the source record type it is `runtime-b`. Runtime representations must match. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/record_rest_field_runtime_name_mismatch.res b/tests/build_tests/super_errors/fixtures/record_rest_field_runtime_name_mismatch.res new file mode 100644 index 00000000000..9c0d20dee06 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/record_rest_field_runtime_name_mismatch.res @@ -0,0 +1,12 @@ +type source = { + a: int, + @as("runtime-b") + b: string, +} + +type wrong = { + @as("other-b") + b: string, +} + +let {a, ...wrong as rest} = ({a: 1, b: "x"}: source) diff --git a/tests/tests/src/record_rest_test.mjs b/tests/tests/src/record_rest_test.mjs index d08838c14b6..694fbf2f7fd 100644 --- a/tests/tests/src/record_rest_test.mjs +++ b/tests/tests/src/record_rest_test.mjs @@ -11,6 +11,10 @@ function describeConfig(c) { ]; } +function getRenamedRest(param) { + return ((({"user-name": __unused0, ...__rest}) => __rest))(param); +} + function getName(param) { return param.name; } @@ -39,6 +43,10 @@ function getInlineWrappedRest(wrapped) { return ((({TAG: __unused0, name: __unused1, ...__rest}) => __rest))(wrapped); } +function getRenamedInlineWrappedRest(wrapped) { + return ((({TAG: __unused0, "user-name": __unused1, ...__rest}) => __rest))(wrapped); +} + function getCustomTaggedInlineWrappedRest(wrapped) { return ((({kind: __unused0, name: __unused1, ...__rest}) => __rest))(wrapped); } @@ -54,13 +62,13 @@ Mocha.describe("Record_rest_test", () => { version: "1.0", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 95, characters 7-14", "test", "test"); - Test_utils.eq("File \"record_rest_test.res\", line 96, characters 7-14", rest, { + Test_utils.eq("File \"record_rest_test.res\", line 124, characters 7-14", "test", "test"); + Test_utils.eq("File \"record_rest_test.res\", line 125, characters 7-14", rest, { version: "1.0", debug: true }); }); - Mocha.test("match arm returns the named field and the rest record", () => Test_utils.eq("File \"record_rest_test.res\", line 101, characters 6-13", describeConfig({ + Mocha.test("match arm returns the named field and the rest record", () => Test_utils.eq("File \"record_rest_test.res\", line 130, characters 6-13", describeConfig({ name: "match", version: "2.0", debug: false @@ -71,12 +79,20 @@ Mocha.describe("Record_rest_test", () => { debug: false } ])); - Mocha.test("function parameter destructuring keeps the named field", () => Test_utils.eq("File \"record_rest_test.res\", line 108, characters 7-14", getName({ + Mocha.test("function parameter destructuring keeps the named field", () => Test_utils.eq("File \"record_rest_test.res\", line 137, characters 7-14", getName({ name: "param", version: "3.0", debug: true }), "param")); - Mocha.test("empty-field rest pattern still binds the whole record", () => Test_utils.eq("File \"record_rest_test.res\", line 113, characters 6-13", ((({...__rest}) => __rest))({ + Mocha.test("record rest excludes fields renamed with @as", () => Test_utils.eq("File \"record_rest_test.res\", line 142, characters 6-13", getRenamedRest({ + "user-name": "renamed", + version: "3.2", + debug: true + }), { + version: "3.2", + debug: true + })); + Mocha.test("empty-field rest pattern still binds the whole record", () => Test_utils.eq("File \"record_rest_test.res\", line 150, characters 6-13", ((({...__rest}) => __rest))({ name: "whole", version: "3.5", debug: false @@ -92,7 +108,7 @@ Mocha.describe("Record_rest_test", () => { style: "bold", onClick: onClick }); - Test_utils.eq("File \"record_rest_test.res\", line 122, characters 7-14", rest, { + Test_utils.eq("File \"record_rest_test.res\", line 159, characters 7-14", rest, { style: "bold", onClick: onClick }); @@ -102,18 +118,18 @@ Mocha.describe("Record_rest_test", () => { id: "1", value: 42 }); - Test_utils.eq("File \"record_rest_test.res\", line 127, characters 7-14", "1", "1"); - Test_utils.eq("File \"record_rest_test.res\", line 128, characters 7-14", intRest, { + Test_utils.eq("File \"record_rest_test.res\", line 164, characters 7-14", "1", "1"); + Test_utils.eq("File \"record_rest_test.res\", line 165, characters 7-14", intRest, { value: 42 }); - Test_utils.eq("File \"record_rest_test.res\", line 129, characters 7-14", ((({id: __unused0, ...__rest}) => __rest))({ + Test_utils.eq("File \"record_rest_test.res\", line 166, characters 7-14", ((({id: __unused0, ...__rest}) => __rest))({ id: "2", value: "hello" }), { value: "hello" }); }); - Mocha.test("tuple nested record rest is initialized", () => Test_utils.eq("File \"record_rest_test.res\", line 134, characters 6-13", getTupleRest([ + Mocha.test("tuple nested record rest is initialized", () => Test_utils.eq("File \"record_rest_test.res\", line 171, characters 6-13", getTupleRest([ { name: "tuple", version: "4.0", @@ -125,7 +141,7 @@ Mocha.describe("Record_rest_test", () => { debug: false })); Mocha.test("variant payload rest works through the or-pattern path", () => { - Test_utils.eq("File \"record_rest_test.res\", line 142, characters 6-13", getWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 179, characters 6-13", getWrappedRest({ TAG: "Wrap", _0: { name: "wrapped", @@ -136,7 +152,7 @@ Mocha.describe("Record_rest_test", () => { version: "5.0", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 147, characters 6-13", getWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 184, characters 6-13", getWrappedRest({ TAG: "Mirror", _0: { name: "mirror", @@ -149,7 +165,7 @@ Mocha.describe("Record_rest_test", () => { }); }); Mocha.test("inline record variant rest removes the runtime tag field", () => { - Test_utils.eq("File \"record_rest_test.res\", line 155, characters 6-13", getInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 192, characters 6-13", getInlineWrappedRest({ TAG: "InlineWrap", name: "inline", version: "7.0", @@ -158,7 +174,7 @@ Mocha.describe("Record_rest_test", () => { version: "7.0", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 160, characters 6-13", getInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 197, characters 6-13", getInlineWrappedRest({ TAG: "InlineMirror", name: "inlineMirror", version: "8.0", @@ -168,8 +184,28 @@ Mocha.describe("Record_rest_test", () => { debug: false }); }); + Mocha.test("inline record variant rest excludes fields renamed with @as", () => { + Test_utils.eq("File \"record_rest_test.res\", line 205, characters 6-13", getRenamedInlineWrappedRest({ + TAG: "RenamedInlineWrap", + "user-name": "inlineRenamed", + version: "8.5", + debug: true + }), { + version: "8.5", + debug: true + }); + Test_utils.eq("File \"record_rest_test.res\", line 212, characters 6-13", getRenamedInlineWrappedRest({ + TAG: "RenamedInlineMirror", + "user-name": "inlineRenamed2", + version: "8.6", + debug: false + }), { + version: "8.6", + debug: false + }); + }); Mocha.test("inline record variant rest removes a custom runtime tag field", () => { - Test_utils.eq("File \"record_rest_test.res\", line 168, characters 6-13", getCustomTaggedInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 222, characters 6-13", getCustomTaggedInlineWrappedRest({ kind: "CustomInlineWrap", name: "customInline", version: "9.0", @@ -178,7 +214,7 @@ Mocha.describe("Record_rest_test", () => { version: "9.0", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 175, characters 6-13", getCustomTaggedInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 229, characters 6-13", getCustomTaggedInlineWrappedRest({ kind: "CustomInlineMirror", name: "customInlineMirror", version: "10.0", @@ -189,7 +225,7 @@ Mocha.describe("Record_rest_test", () => { }); }); Mocha.test("inline record rest works with a non-identifier custom tag name", () => { - Test_utils.eq("File \"record_rest_test.res\", line 185, characters 6-13", getDashedTaggedInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 239, characters 6-13", getDashedTaggedInlineWrappedRest({ "custom-tag": "DashedInlineWrap", name: "dashedInline", version: "11.0", @@ -198,7 +234,7 @@ Mocha.describe("Record_rest_test", () => { version: "11.0", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 192, characters 6-13", getDashedTaggedInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 246, characters 6-13", getDashedTaggedInlineWrappedRest({ "custom-tag": "DashedInlineMirror", name: "dashedInlineMirror", version: "12.0", @@ -212,6 +248,7 @@ Mocha.describe("Record_rest_test", () => { export { describeConfig, + getRenamedRest, getName, getWholeConfig, extractClassName, @@ -219,6 +256,7 @@ export { getTupleRest, getWrappedRest, getInlineWrappedRest, + getRenamedInlineWrappedRest, getCustomTaggedInlineWrappedRest, getDashedTaggedInlineWrappedRest, } diff --git a/tests/tests/src/record_rest_test.res b/tests/tests/src/record_rest_test.res index fa014dd561b..ca9d22a571e 100644 --- a/tests/tests/src/record_rest_test.res +++ b/tests/tests/src/record_rest_test.res @@ -12,11 +12,20 @@ type subConfig = { debug: bool, } +type renamedConfig = { + @as("user-name") + name: string, + version: string, + debug: bool, +} + let describeConfig = (c: config) => switch c { | {name, ...subConfig as rest} => (name, rest) } +let getRenamedRest = ({name: _, ...subConfig as rest}: renamedConfig) => rest + let getName = ({name, ...subConfig as _rest}: config) => name let getWholeConfig = ({...config as rest}: config) => rest @@ -67,6 +76,26 @@ let getInlineWrappedRest = wrapped => | InlineMirror({name: _, ...subConfig as rest}) => rest } +type renamedInlineWrapped = + | RenamedInlineWrap({ + @as("user-name") + name: string, + version: string, + debug: bool, + }) + | RenamedInlineMirror({ + @as("user-name") + name: string, + version: string, + debug: bool, + }) + +let getRenamedInlineWrappedRest = wrapped => + switch wrapped { + | RenamedInlineWrap({name: _, ...subConfig as rest}) + | RenamedInlineMirror({name: _, ...subConfig as rest}) => rest + } + @tag("kind") type customTaggedInlineWrapped = | CustomInlineWrap({name: string, version: string, debug: bool}) @@ -108,6 +137,14 @@ describe(__MODULE__, () => { eq(__LOC__, getName({name: "param", version: "3.0", debug: true}), "param") }) + test("record rest excludes fields renamed with @as", () => { + eq( + __LOC__, + getRenamedRest({name: "renamed", version: "3.2", debug: true}), + {version: "3.2", debug: true}, + ) + }) + test("empty-field rest pattern still binds the whole record", () => { eq( __LOC__, @@ -163,6 +200,23 @@ describe(__MODULE__, () => { ) }) + test("inline record variant rest excludes fields renamed with @as", () => { + eq( + __LOC__, + getRenamedInlineWrappedRest( + RenamedInlineWrap({name: "inlineRenamed", version: "8.5", debug: true}), + ), + {version: "8.5", debug: true}, + ) + eq( + __LOC__, + getRenamedInlineWrappedRest( + RenamedInlineMirror({name: "inlineRenamed2", version: "8.6", debug: false}), + ), + {version: "8.6", debug: false}, + ) + }) + test("inline record variant rest removes a custom runtime tag field", () => { eq( __LOC__, From e6673826dec564a02b07e58d32c5d9aa98c93d08 Mon Sep 17 00:00:00 2001 From: tsnobip Date: Thu, 2 Apr 2026 18:17:50 +0200 Subject: [PATCH 15/22] support record type alias in rest --- compiler/ml/ast_mapper_from0.ml | 14 ++++- compiler/ml/ast_mapper_to0.ml | 7 ++- compiler/ml/parsetree0.ml | 14 ----- compiler/ml/typecore.ml | 78 ++++++++++++++++++---------- tests/tests/src/record_rest_test.mjs | 55 ++++++++++++-------- tests/tests/src/record_rest_test.res | 12 +++++ 6 files changed, 115 insertions(+), 65 deletions(-) diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index e565cda05b5..4f9412f146d 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -93,6 +93,18 @@ let for_await_of_attr_name = "_res.for_await_of" let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} +let record_rest_attr_name = "res.record_rest" + +let get_record_rest_attr attrs_ = + let rec remove_record_rest_attr acc = function + | ({Location.txt = attr_name; _}, Pt.PPat (rest, None)) :: attrs + when attr_name = record_rest_attr_name -> + (Some rest, List.rev_append acc attrs) + | attr :: attrs -> remove_record_rest_attr (attr :: acc) attrs + | [] -> (None, List.rev acc) + in + remove_record_rest_attr [] attrs_ + module T = struct (* Type expressions for the core language *) @@ -656,7 +668,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) -> - let rest, attrs = Parsetree0.get_record_rest_attr attrs in + let rest, attrs = get_record_rest_attr attrs in record ~loc ~attrs ?rest (Ext_list.map lpl (fun (lid, p) -> let lid1 = map_loc sub lid in diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index 73aea1625f5..6ce4b7e80d2 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -87,6 +87,11 @@ let for_await_of_attr_name = "_res.for_await_of" let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} +let record_rest_attr_name = "res.record_rest" + +let add_record_rest_attr ~rest attrs = + (Location.mknoloc record_rest_attr_name, Pt.PPat (rest, None)) :: attrs + module T = struct (* Type expressions for the core language *) @@ -606,7 +611,7 @@ module P = struct match rest with | None -> attrs | Some rest_pat -> - Parsetree0.add_record_rest_attr ~rest:(sub.pat sub rest_pat) attrs + add_record_rest_attr ~rest:(sub.pat sub rest_pat) attrs in record ~loc ~attrs (Ext_list.map lpl (fun {lid; x = p; opt = optional} -> diff --git a/compiler/ml/parsetree0.ml b/compiler/ml/parsetree0.ml index db5d75ee1a9..ef786dfd25d 100644 --- a/compiler/ml/parsetree0.ml +++ b/compiler/ml/parsetree0.ml @@ -597,7 +597,6 @@ and module_binding = { let optional_attr = (Location.mknoloc "res.optional", Parsetree.PStr []) let optional_attr0 = (Location.mknoloc "res.optional", PStr []) -let record_rest_attr_name = "res.record_rest" let add_optional_attr ~optional attrs = if optional then optional_attr0 :: attrs else attrs @@ -609,16 +608,3 @@ let get_optional_attr attrs_ = let attrs = remove_optional_attr attrs_ in let optional = List.length attrs <> List.length attrs_ in (optional, attrs) - -let add_record_rest_attr ~rest attrs = - (Location.mknoloc record_rest_attr_name, PPat (rest, None)) :: attrs - -let get_record_rest_attr attrs_ = - let rec remove_record_rest_attr acc = function - | ({Location.txt = attr_name; _}, Parsetree.PPat (rest, None)) :: attrs - when attr_name = record_rest_attr_name -> - (Some rest, List.rev_append acc attrs) - | attr :: attrs -> remove_record_rest_attr (attr :: acc) attrs - | [] -> (None, List.rev acc) - in - remove_record_rest_attr [] attrs_ diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index ba9ff1020d1..a3c7de9faa2 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -364,6 +364,19 @@ let unify_pat_types loc env ty ty' = try unify env ty ty' with Unify trace -> raise (Error (loc, env, Pattern_type_clash trace)) +let extract_instantiated_concrete_typedecl env loc ty = + let _, _, decl = extract_concrete_typedecl env ty in + let decl = instance_declaration decl in + let args = + match expand_head env ty with + | {desc = Tconstr (_, args, _)} -> args + | _ -> assert false + in + List.iter2 + (fun param arg -> unify_pat_types loc env param arg) + decl.type_params args; + decl + (* unification inside type_exp and type_expect *) let unify_exp_types ~context loc env ty expected_ty = try unify env ty expected_ty @@ -1606,18 +1619,11 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp raise (Error (rest_pat.ppat_loc, !env, Record_rest_invalid_type)) in (* Look up the rest record type *) - let rest_path, rest_decl = + let rest_path, rest_annotation_decl = Typetexp.find_type !env rest_type_lid.loc rest_type_lid.txt in - let rest_decl = - match rest_decl.type_kind with - | Type_record _ -> instance_declaration rest_decl - | _ -> - raise - (Error - ( rest_type_lid.loc, - !env, - Record_rest_not_record rest_type_lid.txt )) + let rest_annotation_decl = + instance_declaration rest_annotation_decl in (* Get explicit field names *) let explicit_fields = @@ -1630,10 +1636,11 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp in let rest_type_args = match rest_type_args_syntax with - | [] -> List.map (fun _ -> newvar ()) rest_decl.type_params + | [] -> + List.map (fun _ -> newvar ()) rest_annotation_decl.type_params | args -> let n_args = List.length args in - let n_params = List.length rest_decl.type_params in + let n_params = List.length rest_annotation_decl.type_params in if n_args <> n_params then raise (Typetexp.Error @@ -1653,30 +1660,45 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp let rest_type_expr = newgenty (Tconstr (rest_path, rest_type_args, ref Mnil)) in - if rest_decl.type_private = Private then + if rest_annotation_decl.type_private = Private then raise (Error (rest_type_lid.loc, !env, Private_type rest_type_expr)); List.iter2 (fun param arg -> unify_pat_types rest_type_lid.loc !env param arg) - rest_decl.type_params rest_type_args; + rest_annotation_decl.type_params rest_type_args; + let rest_decl = + match + try + Some + (extract_instantiated_concrete_typedecl !env rest_type_lid.loc + rest_type_expr) + with Not_found -> None + with + | Some rest_decl -> ( + if rest_decl.type_private = Private then + raise + (Error (rest_type_lid.loc, !env, Private_type rest_type_expr)); + match rest_decl.type_kind with + | Type_record _ -> rest_decl + | _ -> + raise + (Error + ( rest_type_lid.loc, + !env, + Record_rest_not_record rest_type_lid.txt ))) + | None -> + raise + (Error + ( rest_type_lid.loc, + !env, + Record_rest_not_record rest_type_lid.txt )) + in let source_fields, source_repr = match try - let _, _, source_decl = - extract_concrete_typedecl !env record_ty - in - let source_decl = instance_declaration source_decl in - let source_type_args = - match expand_head !env record_ty with - | {desc = Tconstr (_, args, _)} -> args - | _ -> assert false - in - Some (source_decl, source_type_args) + Some (extract_instantiated_concrete_typedecl !env loc record_ty) with Not_found -> None with - | Some (source_decl, source_type_args) -> ( - List.iter2 - (fun param arg -> unify_pat_types loc !env param arg) - source_decl.type_params source_type_args; + | Some source_decl -> ( match source_decl.type_kind with | Type_record (fields, repr) -> ( List.map diff --git a/tests/tests/src/record_rest_test.mjs b/tests/tests/src/record_rest_test.mjs index 694fbf2f7fd..515094a26bb 100644 --- a/tests/tests/src/record_rest_test.mjs +++ b/tests/tests/src/record_rest_test.mjs @@ -11,6 +11,10 @@ function describeConfig(c) { ]; } +function getAliasedRest(param) { + return ((({name: __unused0, ...__rest}) => __rest))(param); +} + function getRenamedRest(param) { return ((({"user-name": __unused0, ...__rest}) => __rest))(param); } @@ -62,13 +66,13 @@ Mocha.describe("Record_rest_test", () => { version: "1.0", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 124, characters 7-14", "test", "test"); - Test_utils.eq("File \"record_rest_test.res\", line 125, characters 7-14", rest, { + Test_utils.eq("File \"record_rest_test.res\", line 128, characters 7-14", "test", "test"); + Test_utils.eq("File \"record_rest_test.res\", line 129, characters 7-14", rest, { version: "1.0", debug: true }); }); - Mocha.test("match arm returns the named field and the rest record", () => Test_utils.eq("File \"record_rest_test.res\", line 130, characters 6-13", describeConfig({ + Mocha.test("match arm returns the named field and the rest record", () => Test_utils.eq("File \"record_rest_test.res\", line 134, characters 6-13", describeConfig({ name: "match", version: "2.0", debug: false @@ -79,12 +83,20 @@ Mocha.describe("Record_rest_test", () => { debug: false } ])); - Mocha.test("function parameter destructuring keeps the named field", () => Test_utils.eq("File \"record_rest_test.res\", line 137, characters 7-14", getName({ + Mocha.test("function parameter destructuring keeps the named field", () => Test_utils.eq("File \"record_rest_test.res\", line 141, characters 7-14", getName({ name: "param", version: "3.0", debug: true }), "param")); - Mocha.test("record rest excludes fields renamed with @as", () => Test_utils.eq("File \"record_rest_test.res\", line 142, characters 6-13", getRenamedRest({ + Mocha.test("record rest accepts type aliases to record shapes", () => Test_utils.eq("File \"record_rest_test.res\", line 146, characters 6-13", getAliasedRest({ + name: "aliased", + version: "3.1", + debug: false + }), { + version: "3.1", + debug: false + })); + Mocha.test("record rest excludes fields renamed with @as", () => Test_utils.eq("File \"record_rest_test.res\", line 154, characters 6-13", getRenamedRest({ "user-name": "renamed", version: "3.2", debug: true @@ -92,7 +104,7 @@ Mocha.describe("Record_rest_test", () => { version: "3.2", debug: true })); - Mocha.test("empty-field rest pattern still binds the whole record", () => Test_utils.eq("File \"record_rest_test.res\", line 150, characters 6-13", ((({...__rest}) => __rest))({ + Mocha.test("empty-field rest pattern still binds the whole record", () => Test_utils.eq("File \"record_rest_test.res\", line 162, characters 6-13", ((({...__rest}) => __rest))({ name: "whole", version: "3.5", debug: false @@ -108,7 +120,7 @@ Mocha.describe("Record_rest_test", () => { style: "bold", onClick: onClick }); - Test_utils.eq("File \"record_rest_test.res\", line 159, characters 7-14", rest, { + Test_utils.eq("File \"record_rest_test.res\", line 171, characters 7-14", rest, { style: "bold", onClick: onClick }); @@ -118,18 +130,18 @@ Mocha.describe("Record_rest_test", () => { id: "1", value: 42 }); - Test_utils.eq("File \"record_rest_test.res\", line 164, characters 7-14", "1", "1"); - Test_utils.eq("File \"record_rest_test.res\", line 165, characters 7-14", intRest, { + Test_utils.eq("File \"record_rest_test.res\", line 176, characters 7-14", "1", "1"); + Test_utils.eq("File \"record_rest_test.res\", line 177, characters 7-14", intRest, { value: 42 }); - Test_utils.eq("File \"record_rest_test.res\", line 166, characters 7-14", ((({id: __unused0, ...__rest}) => __rest))({ + Test_utils.eq("File \"record_rest_test.res\", line 178, characters 7-14", ((({id: __unused0, ...__rest}) => __rest))({ id: "2", value: "hello" }), { value: "hello" }); }); - Mocha.test("tuple nested record rest is initialized", () => Test_utils.eq("File \"record_rest_test.res\", line 171, characters 6-13", getTupleRest([ + Mocha.test("tuple nested record rest is initialized", () => Test_utils.eq("File \"record_rest_test.res\", line 183, characters 6-13", getTupleRest([ { name: "tuple", version: "4.0", @@ -141,7 +153,7 @@ Mocha.describe("Record_rest_test", () => { debug: false })); Mocha.test("variant payload rest works through the or-pattern path", () => { - Test_utils.eq("File \"record_rest_test.res\", line 179, characters 6-13", getWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 191, characters 6-13", getWrappedRest({ TAG: "Wrap", _0: { name: "wrapped", @@ -152,7 +164,7 @@ Mocha.describe("Record_rest_test", () => { version: "5.0", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 184, characters 6-13", getWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 196, characters 6-13", getWrappedRest({ TAG: "Mirror", _0: { name: "mirror", @@ -165,7 +177,7 @@ Mocha.describe("Record_rest_test", () => { }); }); Mocha.test("inline record variant rest removes the runtime tag field", () => { - Test_utils.eq("File \"record_rest_test.res\", line 192, characters 6-13", getInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 204, characters 6-13", getInlineWrappedRest({ TAG: "InlineWrap", name: "inline", version: "7.0", @@ -174,7 +186,7 @@ Mocha.describe("Record_rest_test", () => { version: "7.0", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 197, characters 6-13", getInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 209, characters 6-13", getInlineWrappedRest({ TAG: "InlineMirror", name: "inlineMirror", version: "8.0", @@ -185,7 +197,7 @@ Mocha.describe("Record_rest_test", () => { }); }); Mocha.test("inline record variant rest excludes fields renamed with @as", () => { - Test_utils.eq("File \"record_rest_test.res\", line 205, characters 6-13", getRenamedInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 217, characters 6-13", getRenamedInlineWrappedRest({ TAG: "RenamedInlineWrap", "user-name": "inlineRenamed", version: "8.5", @@ -194,7 +206,7 @@ Mocha.describe("Record_rest_test", () => { version: "8.5", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 212, characters 6-13", getRenamedInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 224, characters 6-13", getRenamedInlineWrappedRest({ TAG: "RenamedInlineMirror", "user-name": "inlineRenamed2", version: "8.6", @@ -205,7 +217,7 @@ Mocha.describe("Record_rest_test", () => { }); }); Mocha.test("inline record variant rest removes a custom runtime tag field", () => { - Test_utils.eq("File \"record_rest_test.res\", line 222, characters 6-13", getCustomTaggedInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 234, characters 6-13", getCustomTaggedInlineWrappedRest({ kind: "CustomInlineWrap", name: "customInline", version: "9.0", @@ -214,7 +226,7 @@ Mocha.describe("Record_rest_test", () => { version: "9.0", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 229, characters 6-13", getCustomTaggedInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 241, characters 6-13", getCustomTaggedInlineWrappedRest({ kind: "CustomInlineMirror", name: "customInlineMirror", version: "10.0", @@ -225,7 +237,7 @@ Mocha.describe("Record_rest_test", () => { }); }); Mocha.test("inline record rest works with a non-identifier custom tag name", () => { - Test_utils.eq("File \"record_rest_test.res\", line 239, characters 6-13", getDashedTaggedInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 251, characters 6-13", getDashedTaggedInlineWrappedRest({ "custom-tag": "DashedInlineWrap", name: "dashedInline", version: "11.0", @@ -234,7 +246,7 @@ Mocha.describe("Record_rest_test", () => { version: "11.0", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 246, characters 6-13", getDashedTaggedInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 258, characters 6-13", getDashedTaggedInlineWrappedRest({ "custom-tag": "DashedInlineMirror", name: "dashedInlineMirror", version: "12.0", @@ -248,6 +260,7 @@ Mocha.describe("Record_rest_test", () => { export { describeConfig, + getAliasedRest, getRenamedRest, getName, getWholeConfig, diff --git a/tests/tests/src/record_rest_test.res b/tests/tests/src/record_rest_test.res index ca9d22a571e..207e4aa15f4 100644 --- a/tests/tests/src/record_rest_test.res +++ b/tests/tests/src/record_rest_test.res @@ -12,6 +12,8 @@ type subConfig = { debug: bool, } +type aliasedSubConfig = subConfig + type renamedConfig = { @as("user-name") name: string, @@ -24,6 +26,8 @@ let describeConfig = (c: config) => | {name, ...subConfig as rest} => (name, rest) } +let getAliasedRest = ({name: _, ...aliasedSubConfig as rest}: config) => rest + let getRenamedRest = ({name: _, ...subConfig as rest}: renamedConfig) => rest let getName = ({name, ...subConfig as _rest}: config) => name @@ -137,6 +141,14 @@ describe(__MODULE__, () => { eq(__LOC__, getName({name: "param", version: "3.0", debug: true}), "param") }) + test("record rest accepts type aliases to record shapes", () => { + eq( + __LOC__, + getAliasedRest({name: "aliased", version: "3.1", debug: false}), + {version: "3.1", debug: false}, + ) + }) + test("record rest excludes fields renamed with @as", () => { eq( __LOC__, From 049aaed4a016ec46819b8737abbc21b96e1ff5eb Mon Sep 17 00:00:00 2001 From: tsnobip Date: Tue, 7 Apr 2026 09:51:27 +0200 Subject: [PATCH 16/22] fix compiler crash when spreading the whole record --- compiler/ml/typecore.ml | 6 ++-- compiler/ml/typedtree.mli | 2 +- tests/tests/src/record_rest_test.mjs | 48 +++++++++++++++++++--------- tests/tests/src/record_rest_test.res | 6 ++++ 4 files changed, 44 insertions(+), 18 deletions(-) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index a3c7de9faa2..134987e77e5 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -546,8 +546,10 @@ let rec build_as_type env p = row_fixed = false; row_closed = false; }) - | Tpat_record (lpl, _, _rest) -> - let lbl = snd4 (List.hd lpl) in + | Tpat_record ([], _, _rest) -> + (* Rest-only record patterns already carry the source record type. *) + p.pat_type + | Tpat_record (((_, lbl, _, _) :: _ as lpl), _, _rest) -> if lbl.lbl_private = Private then p.pat_type else let ty = newvar () in diff --git a/compiler/ml/typedtree.mli b/compiler/ml/typedtree.mli index 345badc805c..939e46d1db6 100644 --- a/compiler/ml/typedtree.mli +++ b/compiler/ml/typedtree.mli @@ -98,7 +98,7 @@ and pattern_desc = (** { l1=P1; ...; ln=Pn } (flag = Closed) { l1=P1; ...; ln=Pn; _} (flag = Open) - Invariant: n > 0 + Invariant: n > 0 unless this is a rest-only record pattern *) | Tpat_array of pattern list (** [| P1; ...; Pn |] *) | Tpat_or of pattern * pattern * row_desc option diff --git a/tests/tests/src/record_rest_test.mjs b/tests/tests/src/record_rest_test.mjs index 515094a26bb..8a293aa6975 100644 --- a/tests/tests/src/record_rest_test.mjs +++ b/tests/tests/src/record_rest_test.mjs @@ -113,6 +113,24 @@ Mocha.describe("Record_rest_test", () => { version: "3.5", debug: false })); + Mocha.test("rest-only record patterns can also bind the whole alias", () => { + let whole = { + name: "wholeAlias", + version: "3.6", + debug: true + }; + let rest = ((({...__rest}) => __rest))(whole); + Test_utils.eq("File \"record_rest_test.res\", line 170, characters 7-14", whole, { + name: "wholeAlias", + version: "3.6", + debug: true + }); + Test_utils.eq("File \"record_rest_test.res\", line 171, characters 7-14", rest, { + name: "wholeAlias", + version: "3.6", + debug: true + }); + }); Mocha.test("optional overlap keeps the remaining fields in the rest object", () => { let onClick = () => {}; let rest = extractClassName({ @@ -120,7 +138,7 @@ Mocha.describe("Record_rest_test", () => { style: "bold", onClick: onClick }); - Test_utils.eq("File \"record_rest_test.res\", line 171, characters 7-14", rest, { + Test_utils.eq("File \"record_rest_test.res\", line 177, characters 7-14", rest, { style: "bold", onClick: onClick }); @@ -130,18 +148,18 @@ Mocha.describe("Record_rest_test", () => { id: "1", value: 42 }); - Test_utils.eq("File \"record_rest_test.res\", line 176, characters 7-14", "1", "1"); - Test_utils.eq("File \"record_rest_test.res\", line 177, characters 7-14", intRest, { + Test_utils.eq("File \"record_rest_test.res\", line 182, characters 7-14", "1", "1"); + Test_utils.eq("File \"record_rest_test.res\", line 183, characters 7-14", intRest, { value: 42 }); - Test_utils.eq("File \"record_rest_test.res\", line 178, characters 7-14", ((({id: __unused0, ...__rest}) => __rest))({ + Test_utils.eq("File \"record_rest_test.res\", line 184, characters 7-14", ((({id: __unused0, ...__rest}) => __rest))({ id: "2", value: "hello" }), { value: "hello" }); }); - Mocha.test("tuple nested record rest is initialized", () => Test_utils.eq("File \"record_rest_test.res\", line 183, characters 6-13", getTupleRest([ + Mocha.test("tuple nested record rest is initialized", () => Test_utils.eq("File \"record_rest_test.res\", line 189, characters 6-13", getTupleRest([ { name: "tuple", version: "4.0", @@ -153,7 +171,7 @@ Mocha.describe("Record_rest_test", () => { debug: false })); Mocha.test("variant payload rest works through the or-pattern path", () => { - Test_utils.eq("File \"record_rest_test.res\", line 191, characters 6-13", getWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 197, characters 6-13", getWrappedRest({ TAG: "Wrap", _0: { name: "wrapped", @@ -164,7 +182,7 @@ Mocha.describe("Record_rest_test", () => { version: "5.0", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 196, characters 6-13", getWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 202, characters 6-13", getWrappedRest({ TAG: "Mirror", _0: { name: "mirror", @@ -177,7 +195,7 @@ Mocha.describe("Record_rest_test", () => { }); }); Mocha.test("inline record variant rest removes the runtime tag field", () => { - Test_utils.eq("File \"record_rest_test.res\", line 204, characters 6-13", getInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 210, characters 6-13", getInlineWrappedRest({ TAG: "InlineWrap", name: "inline", version: "7.0", @@ -186,7 +204,7 @@ Mocha.describe("Record_rest_test", () => { version: "7.0", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 209, characters 6-13", getInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 215, characters 6-13", getInlineWrappedRest({ TAG: "InlineMirror", name: "inlineMirror", version: "8.0", @@ -197,7 +215,7 @@ Mocha.describe("Record_rest_test", () => { }); }); Mocha.test("inline record variant rest excludes fields renamed with @as", () => { - Test_utils.eq("File \"record_rest_test.res\", line 217, characters 6-13", getRenamedInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 223, characters 6-13", getRenamedInlineWrappedRest({ TAG: "RenamedInlineWrap", "user-name": "inlineRenamed", version: "8.5", @@ -206,7 +224,7 @@ Mocha.describe("Record_rest_test", () => { version: "8.5", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 224, characters 6-13", getRenamedInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 230, characters 6-13", getRenamedInlineWrappedRest({ TAG: "RenamedInlineMirror", "user-name": "inlineRenamed2", version: "8.6", @@ -217,7 +235,7 @@ Mocha.describe("Record_rest_test", () => { }); }); Mocha.test("inline record variant rest removes a custom runtime tag field", () => { - Test_utils.eq("File \"record_rest_test.res\", line 234, characters 6-13", getCustomTaggedInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 240, characters 6-13", getCustomTaggedInlineWrappedRest({ kind: "CustomInlineWrap", name: "customInline", version: "9.0", @@ -226,7 +244,7 @@ Mocha.describe("Record_rest_test", () => { version: "9.0", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 241, characters 6-13", getCustomTaggedInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 247, characters 6-13", getCustomTaggedInlineWrappedRest({ kind: "CustomInlineMirror", name: "customInlineMirror", version: "10.0", @@ -237,7 +255,7 @@ Mocha.describe("Record_rest_test", () => { }); }); Mocha.test("inline record rest works with a non-identifier custom tag name", () => { - Test_utils.eq("File \"record_rest_test.res\", line 251, characters 6-13", getDashedTaggedInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 257, characters 6-13", getDashedTaggedInlineWrappedRest({ "custom-tag": "DashedInlineWrap", name: "dashedInline", version: "11.0", @@ -246,7 +264,7 @@ Mocha.describe("Record_rest_test", () => { version: "11.0", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 258, characters 6-13", getDashedTaggedInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 264, characters 6-13", getDashedTaggedInlineWrappedRest({ "custom-tag": "DashedInlineMirror", name: "dashedInlineMirror", version: "12.0", diff --git a/tests/tests/src/record_rest_test.res b/tests/tests/src/record_rest_test.res index 207e4aa15f4..5c8d304853b 100644 --- a/tests/tests/src/record_rest_test.res +++ b/tests/tests/src/record_rest_test.res @@ -165,6 +165,12 @@ describe(__MODULE__, () => { ) }) + test("rest-only record patterns can also bind the whole alias", () => { + let {...config as rest} as whole = ({name: "wholeAlias", version: "3.6", debug: true}: config) + eq(__LOC__, whole, {name: "wholeAlias", version: "3.6", debug: true}) + eq(__LOC__, rest, {name: "wholeAlias", version: "3.6", debug: true}) + }) + test("optional overlap keeps the remaining fields in the rest object", () => { let onClick = () => () let rest = extractClassName({className: "btn", style: "bold", onClick}) From b47e43cb4306f9d9c7649207962f6cb65da45fac Mon Sep 17 00:00:00 2001 From: tsnobip Date: Tue, 7 Apr 2026 10:41:53 +0200 Subject: [PATCH 17/22] disallow rest spreading on packed modules --- compiler/frontend/ast_tuple_pattern_flatten.ml | 6 +++++- .../record_rest_module_destructure.res.expected | 10 ++++++++++ .../fixtures/record_rest_module_destructure.res | 3 +++ 3 files changed, 18 insertions(+), 1 deletion(-) create mode 100644 tests/build_tests/super_errors/expected/record_rest_module_destructure.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/record_rest_module_destructure.res diff --git a/compiler/frontend/ast_tuple_pattern_flatten.ml b/compiler/frontend/ast_tuple_pattern_flatten.ml index 1955936b99b..7b9d3e3da39 100644 --- a/compiler/frontend/ast_tuple_pattern_flatten.ml +++ b/compiler/frontend/ast_tuple_pattern_flatten.ml @@ -64,7 +64,11 @@ let flattern_tuple_pattern_vb (self : Bs_ast_mapper.mapper) } :: acc) | _ -> {pvb_pat; pvb_expr; pvb_loc = vb.pvb_loc; pvb_attributes} :: acc) - | Ppat_record (lid_pats, _, _rest), Pexp_pack {pmod_desc = Pmod_ident id} -> + | Ppat_record (_, _, Some rest), Pexp_pack {pmod_desc = Pmod_ident _} -> + Location.raise_errorf ~loc:rest.ppat_loc + "Record rest patterns are not supported when destructuring modules. Bind \ + the module fields explicitly." + | Ppat_record (lid_pats, _, None), Pexp_pack {pmod_desc = Pmod_ident id} -> Ext_list.map_append lid_pats acc (fun {lid; x = pat} -> match lid.txt with | Lident s -> diff --git a/tests/build_tests/super_errors/expected/record_rest_module_destructure.res.expected b/tests/build_tests/super_errors/expected/record_rest_module_destructure.res.expected new file mode 100644 index 00000000000..185c334b1f0 --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_rest_module_destructure.res.expected @@ -0,0 +1,10 @@ + + We've found a bug for you! + /.../fixtures/record_rest_module_destructure.res:3:15-34 + + 1 │ module A = Belt.Array + 2 │ + 3 │ let {push, ...arrayMethods as rest} = module(A) + 4 │ + + Record rest patterns are not supported when destructuring modules. Bind the module fields explicitly. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/record_rest_module_destructure.res b/tests/build_tests/super_errors/fixtures/record_rest_module_destructure.res new file mode 100644 index 00000000000..7fc1a00fb5e --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/record_rest_module_destructure.res @@ -0,0 +1,3 @@ +module A = Belt.Array + +let {push, ...arrayMethods as rest} = module(A) From b092cb893716d6e14021aae1ce0ade4a3ff37b23 Mon Sep 17 00:00:00 2001 From: tsnobip Date: Fri, 10 Apr 2026 12:12:51 +0200 Subject: [PATCH 18/22] add tests for record rest with namespaced type --- tests/analysis_tests/tests/src/RecordRest.res | 6 +- .../tests/src/expected/RecordRest.res.txt | 4 +- tests/tests/src/record_rest_test.mjs | 75 +++++++++++++------ tests/tests/src/record_rest_test.res | 25 +++++++ 4 files changed, 82 insertions(+), 28 deletions(-) diff --git a/tests/analysis_tests/tests/src/RecordRest.res b/tests/analysis_tests/tests/src/RecordRest.res index cca4d605c92..6e7dd0d2a52 100644 --- a/tests/analysis_tests/tests/src/RecordRest.res +++ b/tests/analysis_tests/tests/src/RecordRest.res @@ -1,9 +1,11 @@ type config = {name: string, version: string} -type subConfig = {version: string} +module SubConfig = { + type t = {version: string} +} let getVersion = (config: config) => switch config { - | {name: _, ...subConfig as rest} => + | {name: _, ...SubConfig.t as rest} => rest.version // ^def } diff --git a/tests/analysis_tests/tests/src/expected/RecordRest.res.txt b/tests/analysis_tests/tests/src/expected/RecordRest.res.txt index 1677d82115c..67434a6c3f2 100644 --- a/tests/analysis_tests/tests/src/expected/RecordRest.res.txt +++ b/tests/analysis_tests/tests/src/expected/RecordRest.res.txt @@ -1,2 +1,2 @@ -Definition src/RecordRest.res 6:4 -{"uri": "RecordRest.res", "range": {"start": {"line": 5, "character": 30}, "end": {"line": 5, "character": 34}}} +Definition src/RecordRest.res 8:4 +{"uri": "RecordRest.res", "range": {"start": {"line": 7, "character": 32}, "end": {"line": 7, "character": 36}}} diff --git a/tests/tests/src/record_rest_test.mjs b/tests/tests/src/record_rest_test.mjs index 8a293aa6975..afdcfc397a7 100644 --- a/tests/tests/src/record_rest_test.mjs +++ b/tests/tests/src/record_rest_test.mjs @@ -3,6 +3,8 @@ import * as Mocha from "mocha"; import * as Test_utils from "./test_utils.mjs"; +let SubConfig = {}; + function describeConfig(c) { let rest = ((({name: __unused0, ...__rest}) => __rest))(c); return [ @@ -15,6 +17,10 @@ function getAliasedRest(param) { return ((({name: __unused0, ...__rest}) => __rest))(param); } +function getNamespacedRest(param) { + return ((({name: __unused0, ...__rest}) => __rest))(param); +} + function getRenamedRest(param) { return ((({"user-name": __unused0, ...__rest}) => __rest))(param); } @@ -66,13 +72,13 @@ Mocha.describe("Record_rest_test", () => { version: "1.0", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 128, characters 7-14", "test", "test"); - Test_utils.eq("File \"record_rest_test.res\", line 129, characters 7-14", rest, { + Test_utils.eq("File \"record_rest_test.res\", line 136, characters 7-14", "test", "test"); + Test_utils.eq("File \"record_rest_test.res\", line 137, characters 7-14", rest, { version: "1.0", debug: true }); }); - Mocha.test("match arm returns the named field and the rest record", () => Test_utils.eq("File \"record_rest_test.res\", line 134, characters 6-13", describeConfig({ + Mocha.test("match arm returns the named field and the rest record", () => Test_utils.eq("File \"record_rest_test.res\", line 142, characters 6-13", describeConfig({ name: "match", version: "2.0", debug: false @@ -83,12 +89,12 @@ Mocha.describe("Record_rest_test", () => { debug: false } ])); - Mocha.test("function parameter destructuring keeps the named field", () => Test_utils.eq("File \"record_rest_test.res\", line 141, characters 7-14", getName({ + Mocha.test("function parameter destructuring keeps the named field", () => Test_utils.eq("File \"record_rest_test.res\", line 149, characters 7-14", getName({ name: "param", version: "3.0", debug: true }), "param")); - Mocha.test("record rest accepts type aliases to record shapes", () => Test_utils.eq("File \"record_rest_test.res\", line 146, characters 6-13", getAliasedRest({ + Mocha.test("record rest accepts type aliases to record shapes", () => Test_utils.eq("File \"record_rest_test.res\", line 154, characters 6-13", getAliasedRest({ name: "aliased", version: "3.1", debug: false @@ -96,7 +102,26 @@ Mocha.describe("Record_rest_test", () => { version: "3.1", debug: false })); - Mocha.test("record rest excludes fields renamed with @as", () => Test_utils.eq("File \"record_rest_test.res\", line 154, characters 6-13", getRenamedRest({ + Mocha.test("record rest accepts namespaced record types", () => { + Test_utils.eq("File \"record_rest_test.res\", line 162, characters 6-13", getNamespacedRest({ + name: "namespaced", + version: "3.15", + debug: true + }), { + version: "3.15", + debug: true + }); + let rest = ((({name: __unused0, ...__rest}) => __rest))({ + name: "namespaced-let", + version: "3.16", + debug: false + }); + Test_utils.eq("File \"record_rest_test.res\", line 174, characters 7-14", rest, { + version: "3.16", + debug: false + }); + }); + Mocha.test("record rest excludes fields renamed with @as", () => Test_utils.eq("File \"record_rest_test.res\", line 179, characters 6-13", getRenamedRest({ "user-name": "renamed", version: "3.2", debug: true @@ -104,7 +129,7 @@ Mocha.describe("Record_rest_test", () => { version: "3.2", debug: true })); - Mocha.test("empty-field rest pattern still binds the whole record", () => Test_utils.eq("File \"record_rest_test.res\", line 162, characters 6-13", ((({...__rest}) => __rest))({ + Mocha.test("empty-field rest pattern still binds the whole record", () => Test_utils.eq("File \"record_rest_test.res\", line 187, characters 6-13", ((({...__rest}) => __rest))({ name: "whole", version: "3.5", debug: false @@ -120,12 +145,12 @@ Mocha.describe("Record_rest_test", () => { debug: true }; let rest = ((({...__rest}) => __rest))(whole); - Test_utils.eq("File \"record_rest_test.res\", line 170, characters 7-14", whole, { + Test_utils.eq("File \"record_rest_test.res\", line 195, characters 7-14", whole, { name: "wholeAlias", version: "3.6", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 171, characters 7-14", rest, { + Test_utils.eq("File \"record_rest_test.res\", line 196, characters 7-14", rest, { name: "wholeAlias", version: "3.6", debug: true @@ -138,7 +163,7 @@ Mocha.describe("Record_rest_test", () => { style: "bold", onClick: onClick }); - Test_utils.eq("File \"record_rest_test.res\", line 177, characters 7-14", rest, { + Test_utils.eq("File \"record_rest_test.res\", line 202, characters 7-14", rest, { style: "bold", onClick: onClick }); @@ -148,18 +173,18 @@ Mocha.describe("Record_rest_test", () => { id: "1", value: 42 }); - Test_utils.eq("File \"record_rest_test.res\", line 182, characters 7-14", "1", "1"); - Test_utils.eq("File \"record_rest_test.res\", line 183, characters 7-14", intRest, { + Test_utils.eq("File \"record_rest_test.res\", line 207, characters 7-14", "1", "1"); + Test_utils.eq("File \"record_rest_test.res\", line 208, characters 7-14", intRest, { value: 42 }); - Test_utils.eq("File \"record_rest_test.res\", line 184, characters 7-14", ((({id: __unused0, ...__rest}) => __rest))({ + Test_utils.eq("File \"record_rest_test.res\", line 209, characters 7-14", ((({id: __unused0, ...__rest}) => __rest))({ id: "2", value: "hello" }), { value: "hello" }); }); - Mocha.test("tuple nested record rest is initialized", () => Test_utils.eq("File \"record_rest_test.res\", line 189, characters 6-13", getTupleRest([ + Mocha.test("tuple nested record rest is initialized", () => Test_utils.eq("File \"record_rest_test.res\", line 214, characters 6-13", getTupleRest([ { name: "tuple", version: "4.0", @@ -171,7 +196,7 @@ Mocha.describe("Record_rest_test", () => { debug: false })); Mocha.test("variant payload rest works through the or-pattern path", () => { - Test_utils.eq("File \"record_rest_test.res\", line 197, characters 6-13", getWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 222, characters 6-13", getWrappedRest({ TAG: "Wrap", _0: { name: "wrapped", @@ -182,7 +207,7 @@ Mocha.describe("Record_rest_test", () => { version: "5.0", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 202, characters 6-13", getWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 227, characters 6-13", getWrappedRest({ TAG: "Mirror", _0: { name: "mirror", @@ -195,7 +220,7 @@ Mocha.describe("Record_rest_test", () => { }); }); Mocha.test("inline record variant rest removes the runtime tag field", () => { - Test_utils.eq("File \"record_rest_test.res\", line 210, characters 6-13", getInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 235, characters 6-13", getInlineWrappedRest({ TAG: "InlineWrap", name: "inline", version: "7.0", @@ -204,7 +229,7 @@ Mocha.describe("Record_rest_test", () => { version: "7.0", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 215, characters 6-13", getInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 240, characters 6-13", getInlineWrappedRest({ TAG: "InlineMirror", name: "inlineMirror", version: "8.0", @@ -215,7 +240,7 @@ Mocha.describe("Record_rest_test", () => { }); }); Mocha.test("inline record variant rest excludes fields renamed with @as", () => { - Test_utils.eq("File \"record_rest_test.res\", line 223, characters 6-13", getRenamedInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 248, characters 6-13", getRenamedInlineWrappedRest({ TAG: "RenamedInlineWrap", "user-name": "inlineRenamed", version: "8.5", @@ -224,7 +249,7 @@ Mocha.describe("Record_rest_test", () => { version: "8.5", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 230, characters 6-13", getRenamedInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 255, characters 6-13", getRenamedInlineWrappedRest({ TAG: "RenamedInlineMirror", "user-name": "inlineRenamed2", version: "8.6", @@ -235,7 +260,7 @@ Mocha.describe("Record_rest_test", () => { }); }); Mocha.test("inline record variant rest removes a custom runtime tag field", () => { - Test_utils.eq("File \"record_rest_test.res\", line 240, characters 6-13", getCustomTaggedInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 265, characters 6-13", getCustomTaggedInlineWrappedRest({ kind: "CustomInlineWrap", name: "customInline", version: "9.0", @@ -244,7 +269,7 @@ Mocha.describe("Record_rest_test", () => { version: "9.0", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 247, characters 6-13", getCustomTaggedInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 272, characters 6-13", getCustomTaggedInlineWrappedRest({ kind: "CustomInlineMirror", name: "customInlineMirror", version: "10.0", @@ -255,7 +280,7 @@ Mocha.describe("Record_rest_test", () => { }); }); Mocha.test("inline record rest works with a non-identifier custom tag name", () => { - Test_utils.eq("File \"record_rest_test.res\", line 257, characters 6-13", getDashedTaggedInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 282, characters 6-13", getDashedTaggedInlineWrappedRest({ "custom-tag": "DashedInlineWrap", name: "dashedInline", version: "11.0", @@ -264,7 +289,7 @@ Mocha.describe("Record_rest_test", () => { version: "11.0", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 264, characters 6-13", getDashedTaggedInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 289, characters 6-13", getDashedTaggedInlineWrappedRest({ "custom-tag": "DashedInlineMirror", name: "dashedInlineMirror", version: "12.0", @@ -277,8 +302,10 @@ Mocha.describe("Record_rest_test", () => { }); export { + SubConfig, describeConfig, getAliasedRest, + getNamespacedRest, getRenamedRest, getName, getWholeConfig, diff --git a/tests/tests/src/record_rest_test.res b/tests/tests/src/record_rest_test.res index 5c8d304853b..68bd07c8aa3 100644 --- a/tests/tests/src/record_rest_test.res +++ b/tests/tests/src/record_rest_test.res @@ -12,6 +12,13 @@ type subConfig = { debug: bool, } +module SubConfig = { + type t = { + version: string, + debug: bool, + } +} + type aliasedSubConfig = subConfig type renamedConfig = { @@ -27,6 +34,7 @@ let describeConfig = (c: config) => } let getAliasedRest = ({name: _, ...aliasedSubConfig as rest}: config) => rest +let getNamespacedRest = ({name: _, ...SubConfig.t as rest}: config) => rest let getRenamedRest = ({name: _, ...subConfig as rest}: renamedConfig) => rest @@ -149,6 +157,23 @@ describe(__MODULE__, () => { ) }) + test("record rest accepts namespaced record types", () => { + eq( + __LOC__, + getNamespacedRest({name: "namespaced", version: "3.15", debug: true}), + {version: "3.15", debug: true}, + ) + + let {name: _, ...SubConfig.t as rest} = ( + { + name: "namespaced-let", + version: "3.16", + debug: false, + }: config + ) + eq(__LOC__, rest, {version: "3.16", debug: false}) + }) + test("record rest excludes fields renamed with @as", () => { eq( __LOC__, From fbc17350a9bb01df0510dfd2433c2a2c20ffa547 Mon Sep 17 00:00:00 2001 From: tsnobip Date: Fri, 10 Apr 2026 14:34:44 +0200 Subject: [PATCH 19/22] make sure rest is used and move logic to its own files --- compiler/core/lam_analysis.ml | 2 +- compiler/core/lam_compile_primitive.ml | 2 +- compiler/core/lam_convert.ml | 3 +- compiler/core/lam_primitive.ml | 4 +- compiler/core/lam_primitive.mli | 2 +- compiler/core/lam_print.ml | 4 +- .../frontend/ast_tuple_pattern_flatten.ml | 2 +- compiler/frontend/bs_ast_mapper.ml | 8 +- compiler/ml/ast_helper.mli | 2 +- compiler/ml/ast_iterator.ml | 6 +- compiler/ml/ast_mapper.ml | 8 +- compiler/ml/ast_mapper_from0.ml | 10 +- compiler/ml/ast_mapper_to0.ml | 10 +- compiler/ml/depend.ml | 2 +- compiler/ml/lambda.ml | 2 +- compiler/ml/lambda.mli | 2 +- compiler/ml/matching.ml | 2 +- compiler/ml/parsetree.ml | 16 +- compiler/ml/pprintast.ml | 19 +- compiler/ml/printast.ml | 9 +- compiler/ml/printlambda.ml | 4 +- compiler/ml/typecore.ml | 354 +----------------- compiler/ml/typecore.mli | 13 +- compiler/ml/typecore_record_rest.ml | 299 +++++++++++++++ compiler/ml/typecore_record_rest.mli | 33 ++ compiler/ml/typedtree.ml | 4 +- compiler/ml/typedtree.mli | 4 +- compiler/syntax/src/res_ast_debugger.ml | 17 +- compiler/syntax/src/res_core.ml | 27 +- compiler/syntax/src/res_printer.ml | 10 +- .../expected/record_rest_duplicate.res.txt | 2 +- .../errors/other/expected/spread.res.txt | 2 +- .../grammar/pattern/expected/record.res.txt | 27 +- .../pattern/expected/parenthesized.res.txt | 2 +- .../recovery/pattern/expected/record.res.txt | 5 +- 35 files changed, 494 insertions(+), 424 deletions(-) create mode 100644 compiler/ml/typecore_record_rest.ml create mode 100644 compiler/ml/typecore_record_rest.mli diff --git a/compiler/core/lam_analysis.ml b/compiler/core/lam_analysis.ml index 8ffc3ea8795..54dac1787b8 100644 --- a/compiler/core/lam_analysis.ml +++ b/compiler/core/lam_analysis.ml @@ -53,7 +53,7 @@ let rec no_side_effects (lam : Lam.t) : bool = (* whether it's mutable or not *) | Pfield _ | Pval_from_option | Pval_from_option_not_nest (* NOP The compiler already [t option] is the same as t *) - | Pduprecord | Precord_spread_new _ + | Pduprecord | Precord_rest _ (* generic primitives *) | Pobjcomp _ | Pobjorder | Pobjmin | Pobjmax | Pobjtag | Pobjsize (* bool primitives *) diff --git a/compiler/core/lam_compile_primitive.ml b/compiler/core/lam_compile_primitive.ml index 499619e057e..9dfffa9fc08 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -609,7 +609,7 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) match args with | [e1] -> E.obj ~dup:e1 [] | _ -> assert false) - | Precord_spread_new excluded -> ( + | Precord_rest excluded -> ( match args with | [e1] -> (* Generate: (({field1: __unused0, ...__rest}) => __rest)(source) diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 1da0c23109e..95ae9d94ae5 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -208,8 +208,7 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = | Psetfield (id, info) -> prim ~primitive:(Psetfield (id, info)) ~args loc | Pduprecord -> prim ~primitive:Pduprecord ~args loc | Ptagged_template -> prim ~primitive:Ptagged_template ~args loc - | Precord_spread_new excluded -> - prim ~primitive:(Precord_spread_new excluded) ~args loc + | Precord_rest excluded -> prim ~primitive:(Precord_rest excluded) ~args loc | Praise _ -> prim ~primitive:Praise ~args loc | Pobjcomp x -> prim ~primitive:(Pobjcomp x) ~args loc | Pobjorder -> prim ~primitive:Pobjorder ~args loc diff --git a/compiler/core/lam_primitive.ml b/compiler/core/lam_primitive.ml index 73fad3d2538..118094da64a 100644 --- a/compiler/core/lam_primitive.ml +++ b/compiler/core/lam_primitive.ml @@ -42,7 +42,7 @@ type t = | Pduprecord (* Tagged template literal: [tag; strings_array; values_array] *) | Ptagged_template - | Precord_spread_new of string list + | Precord_rest of string list (* External call *) | Pjs_call of { prim_name: string; @@ -229,7 +229,7 @@ let eq_primitive_approx (lhs : t) (rhs : t) = | Pnull_to_opt | Pnull_undefined_to_opt | Pis_null | Pis_not_none | Psome | Psome_not_nest | Pis_undefined | Pis_null_undefined | Pimport | Ptypeof | Pfn_arity | Pis_poly_var_block | Pdebugger | Pinit_mod | Pupdate_mod - | Pduprecord | Precord_spread_new _ | Pmakearray | Parraylength | Parrayrefu + | Pduprecord | Precord_rest _ | Pmakearray | Parraylength | Parrayrefu | Parraysetu | Parrayrefs | Parraysets | Pjs_fn_make_unit | Pjs_fn_method | Phash | Phash_mixstring | Phash_mixint | Phash_finalmix -> rhs = lhs diff --git a/compiler/core/lam_primitive.mli b/compiler/core/lam_primitive.mli index 8a355cc4791..561c9e31255 100644 --- a/compiler/core/lam_primitive.mli +++ b/compiler/core/lam_primitive.mli @@ -37,7 +37,7 @@ type t = | Psetfield of int * Lambda.set_field_dbg_info | Pduprecord | Ptagged_template - | Precord_spread_new of string list + | Precord_rest of string list | Pjs_call of { (* Location.t * [loc] is passed down *) prim_name: string; diff --git a/compiler/core/lam_print.ml b/compiler/core/lam_print.ml index c8e7f29deb7..446c28e28db 100644 --- a/compiler/core/lam_print.ml +++ b/compiler/core/lam_print.ml @@ -83,8 +83,8 @@ let primitive ppf (prim : Lam_primitive.t) = let instr = "setfield " in fprintf ppf "%s%i" instr n | Pduprecord -> fprintf ppf "duprecord" - | Precord_spread_new excluded -> - fprintf ppf "record_spread_new(%s)" (String.concat ", " excluded) + | Precord_rest excluded -> + fprintf ppf "record_rest(%s)" (String.concat ", " excluded) | Pjs_call {prim_name} -> fprintf ppf "%s[js]" prim_name | Pjs_object_create _ -> fprintf ppf "[js.obj]" | Praise -> fprintf ppf "raise" diff --git a/compiler/frontend/ast_tuple_pattern_flatten.ml b/compiler/frontend/ast_tuple_pattern_flatten.ml index 7b9d3e3da39..165dede4478 100644 --- a/compiler/frontend/ast_tuple_pattern_flatten.ml +++ b/compiler/frontend/ast_tuple_pattern_flatten.ml @@ -65,7 +65,7 @@ let flattern_tuple_pattern_vb (self : Bs_ast_mapper.mapper) :: acc) | _ -> {pvb_pat; pvb_expr; pvb_loc = vb.pvb_loc; pvb_attributes} :: acc) | Ppat_record (_, _, Some rest), Pexp_pack {pmod_desc = Pmod_ident _} -> - Location.raise_errorf ~loc:rest.ppat_loc + Location.raise_errorf ~loc:rest.rest_loc "Record rest patterns are not supported when destructuring modules. Bind \ the module fields explicitly." | Ppat_record (lid_pats, _, None), Pexp_pack {pmod_desc = Pmod_ident id} -> diff --git a/compiler/frontend/bs_ast_mapper.ml b/compiler/frontend/bs_ast_mapper.ml index 31696129001..332ac5b57a2 100644 --- a/compiler/frontend/bs_ast_mapper.ml +++ b/compiler/frontend/bs_ast_mapper.ml @@ -438,7 +438,13 @@ module P = struct ?rest: (match rest with | None -> None - | Some p -> Some (sub.pat sub p)) + | Some {rest_loc; rest_name; rest_type} -> + Some + { + rest_loc = sub.location sub rest_loc; + rest_name = map_loc sub rest_name; + rest_type = map_opt (sub.typ sub) rest_type; + }) (List.map (fun {lid; x = p; opt} -> {lid = map_loc sub lid; x = sub.pat sub p; opt}) diff --git a/compiler/ml/ast_helper.mli b/compiler/ml/ast_helper.mli index 05282cd49fe..ed16a6f9d12 100644 --- a/compiler/ml/ast_helper.mli +++ b/compiler/ml/ast_helper.mli @@ -102,7 +102,7 @@ module Pat : sig val record : ?loc:loc -> ?attrs:attrs -> - ?rest:pattern -> + ?rest:record_pat_rest -> pattern record_element list -> closed_flag -> pattern diff --git a/compiler/ml/ast_iterator.ml b/compiler/ml/ast_iterator.ml index 66be16cf836..f1421d518e7 100644 --- a/compiler/ml/ast_iterator.ml +++ b/compiler/ml/ast_iterator.ml @@ -413,7 +413,11 @@ module P = struct iter_loc sub lid; sub.pat sub pat) lpl; - iter_opt (sub.pat sub) rest + iter_opt + (fun {rest_name; rest_type; _} -> + iter_loc sub rest_name; + iter_opt (sub.typ sub) rest_type) + rest | Ppat_array pl -> List.iter (sub.pat sub) pl | Ppat_or (p1, p2) -> sub.pat sub p1; diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index f7c9b8031cb..8e06c7729eb 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -402,7 +402,13 @@ module P = struct ?rest: (match rest with | None -> None - | Some p -> Some (sub.pat sub p)) + | Some {rest_loc; rest_name; rest_type} -> + Some + { + rest_loc = sub.location sub rest_loc; + rest_name = map_loc sub rest_name; + rest_type = map_opt (sub.typ sub) rest_type; + }) (List.map (fun {lid; x = pat; opt} -> {lid = map_loc sub lid; x = sub.pat sub pat; opt}) diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index 4f9412f146d..080b42b31b0 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -95,11 +95,19 @@ let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} let record_rest_attr_name = "res.record_rest" +let record_rest_of_pattern (rest : Pt.pattern) = + match rest.Pt.ppat_desc with + | Pt.Ppat_constraint ({ppat_desc = Pt.Ppat_var rest_name; _}, rest_type) -> + Some {Pt.rest_loc = rest.ppat_loc; rest_name; rest_type = Some rest_type} + | Pt.Ppat_var rest_name -> + Some {Pt.rest_loc = rest.ppat_loc; rest_name; rest_type = None} + | _ -> None + let get_record_rest_attr attrs_ = let rec remove_record_rest_attr acc = function | ({Location.txt = attr_name; _}, Pt.PPat (rest, None)) :: attrs when attr_name = record_rest_attr_name -> - (Some rest, List.rev_append acc attrs) + (record_rest_of_pattern rest, List.rev_append acc attrs) | attr :: attrs -> remove_record_rest_attr (attr :: acc) attrs | [] -> (None, List.rev acc) in diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index 6ce4b7e80d2..1b05477b169 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -92,6 +92,14 @@ let record_rest_attr_name = "res.record_rest" let add_record_rest_attr ~rest attrs = (Location.mknoloc record_rest_attr_name, Pt.PPat (rest, None)) :: attrs +let record_rest_to_pattern sub (rest : record_pat_rest) = + let loc = sub.location sub rest.rest_loc in + let name = map_loc sub rest.rest_name in + let pat = Ast_helper0.Pat.var ~loc name in + match rest.rest_type with + | None -> pat + | Some typ -> Ast_helper0.Pat.constraint_ ~loc pat (sub.typ sub typ) + module T = struct (* Type expressions for the core language *) @@ -611,7 +619,7 @@ module P = struct match rest with | None -> attrs | Some rest_pat -> - add_record_rest_attr ~rest:(sub.pat sub rest_pat) attrs + add_record_rest_attr ~rest:(record_rest_to_pattern sub rest_pat) attrs in record ~loc ~attrs (Ext_list.map lpl (fun {lid; x = p; opt = optional} -> diff --git a/compiler/ml/depend.ml b/compiler/ml/depend.ml index dc5442cdc6a..d89fb0a0b63 100644 --- a/compiler/ml/depend.ml +++ b/compiler/ml/depend.ml @@ -185,7 +185,7 @@ let rec add_pattern bv pat = add bv lbl; add_pattern bv p) pl; - add_opt add_pattern bv _rest + add_opt (fun bv {rest_type; _} -> add_opt add_type bv rest_type) bv _rest | Ppat_array pl -> List.iter (add_pattern bv) pl | Ppat_or (p1, p2) -> add_pattern bv p1; diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 5324f00aa23..ea759e2a506 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -177,7 +177,7 @@ type primitive = | Pfield of int * field_dbg_info | Psetfield of int * set_field_dbg_info | Pduprecord - | Precord_spread_new of string list (* excluded field names *) + | Precord_rest of string list (* excluded runtime field names *) (* External call *) | Pccall of Primitive.description (* Exceptions *) diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 16fe7036d2d..43b42c58498 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -146,7 +146,7 @@ type primitive = | Pfield of int * field_dbg_info | Psetfield of int * set_field_dbg_info | Pduprecord - | Precord_spread_new of string list (* excluded field names *) + | Precord_rest of string list (* excluded runtime field names *) (* External call *) | Pccall of Primitive.description (* Exceptions *) diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index 61b6b0766ba..eccb49475a0 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -548,7 +548,7 @@ let bind_record_rest loc arg rest action = ( Strict, Pgenval, rest.rest_ident, - Lprim (Precord_spread_new rest.excluded_labels, [arg], loc), + Lprim (Precord_rest rest.excluded_runtime_labels, [arg], loc), action ) let simplify_cases args cls = diff --git a/compiler/ml/parsetree.ml b/compiler/ml/parsetree.ml index fc4709b4efb..8190983e48f 100644 --- a/compiler/ml/parsetree.ml +++ b/compiler/ml/parsetree.ml @@ -161,6 +161,12 @@ and pattern = { ppat_attributes: attributes; (* ... [@id1] [@id2] *) } +and record_pat_rest = { + rest_loc: Location.t; + rest_name: string loc; + rest_type: core_type option; +} + and pattern_desc = | Ppat_any (* _ *) | Ppat_var of string loc (* x *) @@ -184,10 +190,12 @@ and pattern_desc = (* `A (None) `A P (Some P) *) - | Ppat_record of pattern record_element list * closed_flag * pattern option - (* { l1=P1; ...; ln=Pn } (flag = Closed, rest = None) - { l1=P1; ...; ln=Pn; _} (flag = Open, rest = None) - { l1=P1; ...; ...T as r } (rest = Some pattern) + | Ppat_record of + pattern record_element list * closed_flag * record_pat_rest option + (* { l1=P1; ...; ln=Pn } (flag = Closed, rest = None) + { l1=P1; ...; ln=Pn; _} (flag = Open, rest = None) + { l1=P1; ...; ...T as r } (rest = Some {rest_type = Some T; _}) + { l1=P1; ...; ...restName } (rest = Some {rest_type = None; _}) Invariant: n > 0 *) diff --git a/compiler/ml/pprintast.ml b/compiler/ml/pprintast.ml index b079c5579ca..4e9d81ae716 100644 --- a/compiler/ml/pprintast.ml +++ b/compiler/ml/pprintast.ml @@ -460,7 +460,7 @@ and simple_pattern ctxt (f : Format.formatter) (x : pattern) : unit = | Ppat_array l -> pp f "@[<2>[|%a|]@]" (list (pattern1 ctxt) ~sep:";") l | Ppat_unpack s -> pp f "(module@ %s)@ " s.txt | Ppat_type li -> pp f "#%a" longident_loc li - | Ppat_record (l, closed, _rest) -> ( + | Ppat_record (l, closed, rest) -> ( let longident_x_pattern f {lid = li; x = p; opt} = let opt_str = if opt then "?" else "" in match (li, p) with @@ -471,9 +471,20 @@ and simple_pattern ctxt (f : Format.formatter) (x : pattern) : unit = | _ -> pp f "@[<2>%a%s@;=@;%a@]" longident_loc li opt_str (pattern1 ctxt) p in - match closed with - | Closed -> pp f "@[<2>{@;%a@;}@]" (list longident_x_pattern ~sep:";@;") l - | _ -> pp f "@[<2>{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l) + let pp_rest f = function + | {rest_name; rest_type = Some rest_type; _} -> + pp f "...%a as %s" (core_type ctxt) rest_type rest_name.txt + | {rest_name; rest_type = None; _} -> pp f "...%s" rest_name.txt + in + match (closed, rest) with + | Closed, None -> + pp f "@[<2>{@;%a@;}@]" (list longident_x_pattern ~sep:";@;") l + | Open, None -> + pp f "@[<2>{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l + | _, Some rest_pat -> + let pp_fields = list longident_x_pattern ~sep:";@;" in + if l = [] then pp f "@[<2>{@;%a@;}@]" pp_rest rest_pat + else pp f "@[<2>{@;%a;@;%a@;}@]" pp_fields l pp_rest rest_pat) | Ppat_tuple l -> pp f "@[<1>(%a)@]" (list ~sep:",@;" (pattern1 ctxt)) l (* level1*) | Ppat_constant c -> pp f "%a" constant c diff --git a/compiler/ml/printast.ml b/compiler/ml/printast.ml index 3f4cad224a3..4c99c77e433 100644 --- a/compiler/ml/printast.ml +++ b/compiler/ml/printast.ml @@ -205,9 +205,14 @@ and pattern i ppf x = | Ppat_variant (l, po) -> line i ppf "Ppat_variant \"%s\"\n" l; option i pattern ppf po - | Ppat_record (l, c, _rest) -> + | Ppat_record (l, c, rest) -> ( line i ppf "Ppat_record %a\n" fmt_closed_flag c; - list i longident_x_pattern ppf l + list i longident_x_pattern ppf l; + match rest with + | None -> () + | Some {rest_name; rest_type; _} -> + line (i + 1) ppf "rest %a\n" fmt_string_loc rest_name; + option (i + 2) core_type ppf rest_type) | Ppat_array l -> line i ppf "Ppat_array\n"; list i pattern ppf l diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index aac5010d326..bb5c8832d34 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -116,8 +116,8 @@ let primitive ppf = function | Pfield (n, fld) -> fprintf ppf "field:%s/%i" (str_of_field_info fld) n | Psetfield (n, _) -> fprintf ppf "setfield %i" n | Pduprecord -> fprintf ppf "duprecord" - | Precord_spread_new excluded -> - fprintf ppf "record_spread_new(%s)" (String.concat ", " excluded) + | Precord_rest excluded -> + fprintf ppf "record_rest(%s)" (String.concat ", " excluded) | Pccall p -> fprintf ppf "%s" p.prim_name | Praise k -> fprintf ppf "%s" (Lambda.raise_kind k) | Pobjcomp Ceq -> fprintf ppf "==" diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 134987e77e5..f70e3159037 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -96,18 +96,7 @@ type error = | Field_access_on_dict_type | Jsx_not_enabled | Tagged_template_non_tag of type_expr - | Record_rest_invalid_type - | Record_rest_requires_type_annotation of string - | Record_rest_not_record of Longident.t - | Record_rest_field_not_optional of string list * Longident.t - | Record_rest_field_missing of string list * Longident.t - | Record_rest_extra_field of string * Longident.t - | Record_rest_field_runtime_name_mismatch of { - field: string; - rest_type: Longident.t; - source_runtime_name: string; - rest_runtime_name: string; - } + | Record_rest of Typecore_record_rest.error exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -340,15 +329,6 @@ let extract_concrete_variant env ty = | p0, p, {type_kind = Type_open} -> (p0, p, []) | _ -> raise Not_found -let runtime_label_name name attrs = - Ext_list.find_def attrs Lambda.find_name name - -let runtime_label_description_name (lbl : Types.label_description) = - runtime_label_name lbl.lbl_name lbl.lbl_attributes - -let runtime_label_declaration_name (lbl : Types.label_declaration) = - runtime_label_name (Ident.name lbl.ld_id) lbl.ld_attributes - let label_is_optional ld = ld.lbl_optional let check_optional_attr env ld optional loc = @@ -364,19 +344,6 @@ let unify_pat_types loc env ty ty' = try unify env ty ty' with Unify trace -> raise (Error (loc, env, Pattern_type_clash trace)) -let extract_instantiated_concrete_typedecl env loc ty = - let _, _, decl = extract_concrete_typedecl env ty in - let decl = instance_declaration decl in - let args = - match expand_head env ty with - | {desc = Tconstr (_, args, _)} -> args - | _ -> assert false - in - List.iter2 - (fun param arg -> unify_pat_types loc env param arg) - decl.type_params args; - decl - (* unification inside type_exp and type_expect *) let unify_exp_types ~context loc env ty expected_ty = try unify env ty expected_ty @@ -1595,254 +1562,22 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp check_recordpat_labels ~get_jsx_component_error_info loc lbl_pat_list effective_closed; unify_pat_types loc !env record_ty expected_ty; - (* Resolve the rest pattern info *) let typed_rest = match rest with | None -> None - | Some rest_pat -> - (* Extract type annotation and binding name from rest pattern *) - let rest_type_lid, rest_name, rest_type_args_syntax = - match rest_pat.ppat_desc with - | Ppat_constraint ({ppat_desc = Ppat_var name}, cty) -> ( - match cty.ptyp_desc with - | Ptyp_constr (lid, type_args) -> (lid, name, type_args) - | _ -> - raise - (Error (rest_pat.ppat_loc, !env, Record_rest_invalid_type))) - | Ppat_var name -> - (* No type annotation — try to infer from context *) - (* For now, require type annotation *) - raise - (Error - ( rest_pat.ppat_loc, - !env, - Record_rest_requires_type_annotation name.txt )) - | _ -> - raise (Error (rest_pat.ppat_loc, !env, Record_rest_invalid_type)) - in - (* Look up the rest record type *) - let rest_path, rest_annotation_decl = - Typetexp.find_type !env rest_type_lid.loc rest_type_lid.txt - in - let rest_annotation_decl = - instance_declaration rest_annotation_decl - in - (* Get explicit field names *) - let explicit_fields = - List.map (fun (_, label, _, _) -> label.lbl_name) lbl_pat_list - in - let explicit_runtime_fields = - List.map - (fun (_, label, _, _) -> runtime_label_description_name label) - lbl_pat_list - in - let rest_type_args = - match rest_type_args_syntax with - | [] -> - List.map (fun _ -> newvar ()) rest_annotation_decl.type_params - | args -> - let n_args = List.length args in - let n_params = List.length rest_annotation_decl.type_params in - if n_args <> n_params then - raise - (Typetexp.Error - ( rest_type_lid.loc, - !env, - Typetexp.Type_arity_mismatch - (rest_type_lid.txt, n_params, n_args) )); - List.map - (fun sty -> - let cty, force = - Typetexp.transl_simple_type_delayed !env sty - in - pattern_force := force :: !pattern_force; - cty.ctyp_type) - args - in - let rest_type_expr = - newgenty (Tconstr (rest_path, rest_type_args, ref Mnil)) - in - if rest_annotation_decl.type_private = Private then - raise (Error (rest_type_lid.loc, !env, Private_type rest_type_expr)); - List.iter2 - (fun param arg -> unify_pat_types rest_type_lid.loc !env param arg) - rest_annotation_decl.type_params rest_type_args; - let rest_decl = - match - try - Some - (extract_instantiated_concrete_typedecl !env rest_type_lid.loc - rest_type_expr) - with Not_found -> None - with - | Some rest_decl -> ( - if rest_decl.type_private = Private then - raise - (Error (rest_type_lid.loc, !env, Private_type rest_type_expr)); - match rest_decl.type_kind with - | Type_record _ -> rest_decl - | _ -> - raise - (Error - ( rest_type_lid.loc, - !env, - Record_rest_not_record rest_type_lid.txt ))) - | None -> - raise - (Error - ( rest_type_lid.loc, - !env, - Record_rest_not_record rest_type_lid.txt )) - in - let source_fields, source_repr = - match - try - Some (extract_instantiated_concrete_typedecl !env loc record_ty) - with Not_found -> None - with - | Some source_decl -> ( - match source_decl.type_kind with - | Type_record (fields, repr) -> - ( List.map - (fun (l : Types.label_declaration) -> - ( Ident.name l.ld_id, - runtime_label_declaration_name l, - l.ld_type )) - fields, - repr ) - | _ -> assert false) - | None -> ( - unify_pat_types rest_type_lid.loc !env record_ty rest_type_expr; - match rest_decl.type_kind with - | Type_record (fields, repr) -> - ( List.map - (fun (l : Types.label_declaration) -> - ( Ident.name l.ld_id, - runtime_label_declaration_name l, - l.ld_type )) - fields, - repr ) - | _ -> assert false) - in - let rest_labels = - match rest_decl.type_kind with - | Type_record (labels, _) -> labels - | _ -> assert false - in - (* Get explicit optional fields *) - let explicit_optional_fields = - List.filter_map - (fun (_, label, _, opt) -> - if opt then Some label.lbl_name else None) - lbl_pat_list - in - let runtime_excluded_fields = - match source_repr with - | Record_inlined {attrs; _} - when not (Ast_untagged_variants.process_untagged attrs) -> - let tag_name = - match Ast_untagged_variants.process_tag_name attrs with - | Some s -> s - | None -> "TAG" - in - if List.mem tag_name explicit_runtime_fields then - explicit_runtime_fields - else tag_name :: explicit_runtime_fields - | _ -> explicit_runtime_fields - in - (* Get rest field names *) - let rest_field_names = - List.map - (fun (l : Types.label_declaration) -> Ident.name l.ld_id) - rest_labels + | Some rest -> ( + let check_not_private loc ty decl = + if decl.type_private = Private then + raise (Error (loc, !env, Private_type ty)) in - (* Validate: fields in both explicit and rest must be optional in the explicit pattern *) - let not_optional = - List.filter - (fun rest_field -> - List.mem rest_field explicit_fields - && not (List.mem rest_field explicit_optional_fields)) - rest_field_names - in - if not_optional <> [] then - raise - (Error - ( rest_pat.ppat_loc, - !env, - Record_rest_field_not_optional - (not_optional, rest_type_lid.txt) )); - (* Validate: all source fields must be in explicit or rest *) - let source_field_names = - List.map (fun (name, _, _) -> name) source_fields - in - let missing = - List.filter - (fun source_field -> - (not (List.mem source_field explicit_fields)) - && not (List.mem source_field rest_field_names)) - source_field_names - in - if missing <> [] then - raise - (Error - ( rest_pat.ppat_loc, - !env, - Record_rest_field_missing (missing, rest_type_lid.txt) )); - (* Validate: rest type fields must all exist in source and use compatible types *) - List.iter - (fun (rest_label : Types.label_declaration) -> - let rest_field = Ident.name rest_label.ld_id in - let rest_runtime_field = - runtime_label_declaration_name rest_label - in - match - Ext_list.find_first source_fields (fun (field, _, _) -> - field = rest_field) - with - | None -> - raise - (Error - ( rest_type_lid.loc, - !env, - Record_rest_extra_field (rest_field, rest_type_lid.txt) - )) - | Some (_, source_runtime_field, source_type) -> - if source_runtime_field <> rest_runtime_field then - raise - (Error - ( rest_type_lid.loc, - !env, - Record_rest_field_runtime_name_mismatch - { - field = rest_field; - rest_type = rest_type_lid.txt; - source_runtime_name = source_runtime_field; - rest_runtime_name = rest_runtime_field; - } )); - unify_pat_types rest_type_lid.loc !env rest_label.ld_type - source_type) - rest_labels; - (* Warn if all rest fields are already explicit — the rest record will be empty *) - if - rest_field_names <> [] - && List.for_all - (fun f -> List.mem f explicit_fields) - rest_field_names - then - Location.prerr_warning rest_pat.ppat_loc - Warnings.Bs_record_rest_empty; - let rest_ident = - enter_variable rest_pat.ppat_loc rest_name rest_type_expr - in - Some - { - Typedtree.rest_ident; - rest_name; - rest_type = rest_type_expr; - rest_path; - rest_labels; - excluded_labels = runtime_excluded_fields; - } + try + Some + (Typecore_record_rest.type_record_pat_rest ~env:!env + ~pattern_force ~loc ~record_ty ~lbl_pat_list ~rest + ~enter_variable:(fun loc name ty -> enter_variable loc name ty) + ~unify_pat_types ~check_not_private) + with Typecore_record_rest.Error (loc, env, err) -> + raise (Error (loc, env, Record_rest err))) in rp k { @@ -2412,9 +2147,7 @@ let iter_ppat f p = | Ppat_open (_, p) | Ppat_constraint (p, _) -> f p - | Ppat_record (args, _flag, rest) -> - List.iter (fun {x = p} -> f p) args; - may f rest + | Ppat_record (args, _flag, _rest) -> List.iter (fun {x = p} -> f p) args let contains_polymorphic_variant p = let rec loop p = @@ -5367,64 +5100,7 @@ let report_error env loc ppf error = \ - To use a ReScript function as a tag, lift it with \ @{TaggedTemplate.make@}.@]" type_expr typ - | Record_rest_invalid_type -> - fprintf ppf "Record rest pattern must have the form: ...Type.t as name" - | Record_rest_requires_type_annotation name -> - fprintf ppf - "Record rest pattern `...%s` requires a type annotation. Use `...Type.t \ - as %s`." - name name - | Record_rest_not_record lid -> - fprintf ppf - "Type %a is not a record type and cannot be used as a record rest \ - pattern." - longident lid - | Record_rest_field_not_optional (fields, lid) -> ( - let field_list = - fields |> List.map (fun f -> "\n- " ^ f) |> String.concat "" - in - match fields with - | [field] -> - fprintf ppf - "The following field appears in both the explicit pattern and the rest \ - type `%a`:%s\n\n\ - Mark it as optional (`?%s`) in the explicit pattern." - longident lid field_list field - | _ -> - fprintf ppf - "The following fields appear in both the explicit pattern and the rest \ - type `%a`:%s\n\n\ - Mark them as optional (e.g. `?fieldName`) in the explicit pattern." - longident lid field_list) - | Record_rest_field_missing (fields, lid) -> ( - let field_list = - fields |> List.map (fun f -> "\n- " ^ f) |> String.concat "" - in - match fields with - | [_] -> - fprintf ppf - "The following field is not part of the rest type `%a`:%s\n\n\ - List this field in the record pattern before the spread so it's not \ - present in the rest record." - longident lid field_list - | _ -> - fprintf ppf - "The following fields are not part of the rest type `%a`:%s\n\n\ - List these fields in the record pattern before the spread so they're \ - not present in the rest record." - longident lid field_list) - | Record_rest_extra_field (field, lid) -> - fprintf ppf - "Field `%s` in the rest type `%a` does not exist in the source record \ - type." - field longident lid - | Record_rest_field_runtime_name_mismatch - {field; rest_type; source_runtime_name; rest_runtime_name} -> - fprintf ppf - "Field `%s` in the rest type `%a` has runtime representation `%s`, but \ - in the source record type it is `%s`. Runtime representations must \ - match." - field longident rest_type rest_runtime_name source_runtime_name + | Record_rest err -> Typecore_record_rest.report_error ppf err let report_error env loc ppf err = Printtyp.wrap_printing_env env (fun () -> report_error env loc ppf err) diff --git a/compiler/ml/typecore.mli b/compiler/ml/typecore.mli index 03a878e302d..c82b7d2f944 100644 --- a/compiler/ml/typecore.mli +++ b/compiler/ml/typecore.mli @@ -129,18 +129,7 @@ type error = | Field_access_on_dict_type | Jsx_not_enabled | Tagged_template_non_tag of type_expr - | Record_rest_invalid_type - | Record_rest_requires_type_annotation of string - | Record_rest_not_record of Longident.t - | Record_rest_field_not_optional of string list * Longident.t - | Record_rest_field_missing of string list * Longident.t - | Record_rest_extra_field of string * Longident.t - | Record_rest_field_runtime_name_mismatch of { - field: string; - rest_type: Longident.t; - source_runtime_name: string; - rest_runtime_name: string; - } + | Record_rest of Typecore_record_rest.error exception Error of Location.t * Env.t * error exception Error_forward of Location.error diff --git a/compiler/ml/typecore_record_rest.ml b/compiler/ml/typecore_record_rest.ml new file mode 100644 index 00000000000..1a74562408e --- /dev/null +++ b/compiler/ml/typecore_record_rest.ml @@ -0,0 +1,299 @@ +open Types +open Format + +type error = + | Invalid_type + | Requires_type_annotation of string + | Not_record of Longident.t + | Field_not_optional of string list * Longident.t + | Field_missing of string list * Longident.t + | Extra_field of string * Longident.t + | Field_runtime_name_mismatch of { + field: string; + rest_type: Longident.t; + source_runtime_name: string; + rest_runtime_name: string; + } + +exception Error of Location.t * Env.t * error + +type source_field = { + source_name: string; + source_runtime_name: string; + source_type: type_expr; +} + +let raise_error loc env err = raise (Error (loc, env, err)) + +let runtime_label_name name attrs = + Ext_list.find_def attrs Lambda.find_name name + +let runtime_label_description_name (lbl : label_description) = + runtime_label_name lbl.lbl_name lbl.lbl_attributes + +let runtime_label_declaration_name (lbl : label_declaration) = + runtime_label_name (Ident.name lbl.ld_id) lbl.ld_attributes + +let extract_instantiated_concrete_typedecl ~unify_pat_types env loc ty = + let _, _, decl = Ctype.extract_concrete_typedecl env ty in + let decl = Ctype.instance_declaration decl in + let args = + match Ctype.expand_head env ty with + | {desc = Tconstr (_, args, _)} -> args + | _ -> assert false + in + List.iter2 + (fun param arg -> unify_pat_types loc env param arg) + decl.type_params args; + decl + +let type_args_from_annotation ~env ~pattern_force + ~(rest_type_lid : Longident.t Location.loc) rest_decl rest_type_args_syntax + = + match rest_type_args_syntax with + | [] -> List.map (fun _ -> Ctype.newvar ()) rest_decl.type_params + | args -> + let n_args = List.length args in + let n_params = List.length rest_decl.type_params in + if n_args <> n_params then + raise + (Typetexp.Error + ( rest_type_lid.loc, + env, + Typetexp.Type_arity_mismatch (rest_type_lid.txt, n_params, n_args) + )); + List.map + (fun sty -> + let cty, force = Typetexp.transl_simple_type_delayed env sty in + pattern_force := force :: !pattern_force; + cty.ctyp_type) + args + +let source_fields_of_decl (fields : label_declaration list) = + List.map + (fun (field : label_declaration) -> + { + source_name = Ident.name field.ld_id; + source_runtime_name = runtime_label_declaration_name field; + source_type = field.ld_type; + }) + fields + +let resolve_source_record ~env ~unify_pat_types ~loc ~record_ty + ~(rest_type_lid : Longident.t Location.loc) ~rest_type_expr ~rest_decl = + match + try + Some + (extract_instantiated_concrete_typedecl ~unify_pat_types env loc + record_ty) + with Not_found -> None + with + | Some source_decl -> ( + match source_decl.type_kind with + | Type_record (fields, repr) -> (source_fields_of_decl fields, repr) + | _ -> assert false) + | None -> ( + unify_pat_types rest_type_lid.loc env record_ty rest_type_expr; + match rest_decl.type_kind with + | Type_record (fields, repr) -> (source_fields_of_decl fields, repr) + | _ -> assert false) + +let runtime_excluded_labels ~explicit_runtime_labels source_repr = + match source_repr with + | Record_inlined {attrs; _} + when not (Ast_untagged_variants.process_untagged attrs) -> + let tag_name = + match Ast_untagged_variants.process_tag_name attrs with + | Some s -> s + | None -> "TAG" + in + if List.mem tag_name explicit_runtime_labels then explicit_runtime_labels + else tag_name :: explicit_runtime_labels + | _ -> explicit_runtime_labels + +let type_record_pat_rest ~env ~pattern_force ~loc ~record_ty ~lbl_pat_list ~rest + ~enter_variable ~unify_pat_types ~check_not_private = + let rest_type_lid, rest_type_args_syntax = + match rest.Parsetree.rest_type with + | None -> + raise_error rest.rest_loc env + (Requires_type_annotation rest.rest_name.txt) + | Some {ptyp_desc = Ptyp_constr (lid, type_args); _} -> (lid, type_args) + | Some _ -> raise_error rest.rest_loc env Invalid_type + in + let rest_path, rest_annotation_decl = + Typetexp.find_type env rest_type_lid.loc rest_type_lid.txt + in + let rest_annotation_decl = Ctype.instance_declaration rest_annotation_decl in + let rest_type_args = + type_args_from_annotation ~env ~pattern_force ~rest_type_lid + rest_annotation_decl rest_type_args_syntax + in + let rest_type_expr = + Btype.newgenty (Tconstr (rest_path, rest_type_args, ref Mnil)) + in + check_not_private rest_type_lid.loc rest_type_expr rest_annotation_decl; + List.iter2 + (fun param arg -> unify_pat_types rest_type_lid.loc env param arg) + rest_annotation_decl.type_params rest_type_args; + let rest_decl = + match + try + Some + (extract_instantiated_concrete_typedecl ~unify_pat_types env + rest_type_lid.loc rest_type_expr) + with Not_found -> None + with + | Some rest_decl -> ( + check_not_private rest_type_lid.loc rest_type_expr rest_decl; + match rest_decl.type_kind with + | Type_record _ -> rest_decl + | _ -> raise_error rest_type_lid.loc env (Not_record rest_type_lid.txt)) + | None -> raise_error rest_type_lid.loc env (Not_record rest_type_lid.txt) + in + let explicit_fields = + List.map (fun (_, label, _, _) -> label.lbl_name) lbl_pat_list + in + let explicit_runtime_labels = + List.map + (fun (_, label, _, _) -> runtime_label_description_name label) + lbl_pat_list + in + let explicit_optional_fields = + List.filter_map + (fun (_, label, _, optional) -> + if optional then Some label.lbl_name else None) + lbl_pat_list + in + let rest_labels = + match rest_decl.type_kind with + | Type_record (labels, _) -> labels + | _ -> assert false + in + let rest_field_names = + List.map (fun label -> Ident.name label.ld_id) rest_labels + in + let source_fields, source_repr = + resolve_source_record ~env ~unify_pat_types ~loc ~record_ty ~rest_type_lid + ~rest_type_expr ~rest_decl + in + let not_optional = + List.filter + (fun rest_field -> + List.mem rest_field explicit_fields + && not (List.mem rest_field explicit_optional_fields)) + rest_field_names + in + if not_optional <> [] then + raise_error rest.rest_loc env + (Field_not_optional (not_optional, rest_type_lid.txt)); + let source_field_names = + List.map (fun field -> field.source_name) source_fields + in + let missing = + List.filter + (fun source_field -> + (not (List.mem source_field explicit_fields)) + && not (List.mem source_field rest_field_names)) + source_field_names + in + if missing <> [] then + raise_error rest.rest_loc env (Field_missing (missing, rest_type_lid.txt)); + List.iter + (fun (rest_label : label_declaration) -> + let rest_field = Ident.name rest_label.ld_id in + let rest_runtime_name = runtime_label_declaration_name rest_label in + match + Ext_list.find_first source_fields (fun field -> + field.source_name = rest_field) + with + | None -> + raise_error rest_type_lid.loc env + (Extra_field (rest_field, rest_type_lid.txt)) + | Some source_field -> + if source_field.source_runtime_name <> rest_runtime_name then + raise_error rest_type_lid.loc env + (Field_runtime_name_mismatch + { + field = rest_field; + rest_type = rest_type_lid.txt; + source_runtime_name = source_field.source_runtime_name; + rest_runtime_name; + }); + unify_pat_types rest_type_lid.loc env rest_label.ld_type + source_field.source_type) + rest_labels; + if + rest_field_names <> [] + && List.for_all + (fun field -> List.mem field explicit_fields) + rest_field_names + then Location.prerr_warning rest.rest_loc Warnings.Bs_record_rest_empty; + let rest_ident = enter_variable rest.rest_loc rest.rest_name rest_type_expr in + { + Typedtree.rest_ident; + rest_name = rest.rest_name; + rest_type = rest_type_expr; + excluded_runtime_labels = + runtime_excluded_labels ~explicit_runtime_labels source_repr; + } + +let report_error ppf = function + | Invalid_type -> + fprintf ppf "Record rest pattern must have the form: ...Type.t as name" + | Requires_type_annotation name -> + fprintf ppf + "Record rest pattern `...%s` requires a type annotation. Use `...Type.t \ + as %s`." + name name + | Not_record lid -> + fprintf ppf + "Type %a is not a record type and cannot be used as a record rest \ + pattern." + Printtyp.longident lid + | Field_not_optional (fields, lid) -> ( + let field_list = + fields |> List.map (fun field -> "\n- " ^ field) |> String.concat "" + in + match fields with + | [field] -> + fprintf ppf + "The following field appears in both the explicit pattern and the rest \ + type `%a`:%s\n\n\ + Mark it as optional (`?%s`) in the explicit pattern." + Printtyp.longident lid field_list field + | _ -> + fprintf ppf + "The following fields appear in both the explicit pattern and the rest \ + type `%a`:%s\n\n\ + Mark them as optional (e.g. `?fieldName`) in the explicit pattern." + Printtyp.longident lid field_list) + | Field_missing (fields, lid) -> ( + let field_list = + fields |> List.map (fun field -> "\n- " ^ field) |> String.concat "" + in + match fields with + | [_] -> + fprintf ppf + "The following field is not part of the rest type `%a`:%s\n\n\ + List this field in the record pattern before the spread so it's not \ + present in the rest record." + Printtyp.longident lid field_list + | _ -> + fprintf ppf + "The following fields are not part of the rest type `%a`:%s\n\n\ + List these fields in the record pattern before the spread so they're \ + not present in the rest record." + Printtyp.longident lid field_list) + | Extra_field (field, lid) -> + fprintf ppf + "Field `%s` in the rest type `%a` does not exist in the source record \ + type." + field Printtyp.longident lid + | Field_runtime_name_mismatch + {field; rest_type; source_runtime_name; rest_runtime_name} -> + fprintf ppf + "Field `%s` in the rest type `%a` has runtime representation `%s`, but \ + in the source record type it is `%s`. Runtime representations must \ + match." + field Printtyp.longident rest_type rest_runtime_name source_runtime_name diff --git a/compiler/ml/typecore_record_rest.mli b/compiler/ml/typecore_record_rest.mli new file mode 100644 index 00000000000..2a235a7078a --- /dev/null +++ b/compiler/ml/typecore_record_rest.mli @@ -0,0 +1,33 @@ +open Types + +type error = + | Invalid_type + | Requires_type_annotation of string + | Not_record of Longident.t + | Field_not_optional of string list * Longident.t + | Field_missing of string list * Longident.t + | Extra_field of string * Longident.t + | Field_runtime_name_mismatch of { + field: string; + rest_type: Longident.t; + source_runtime_name: string; + rest_runtime_name: string; + } + +exception Error of Location.t * Env.t * error + +val type_record_pat_rest : + env:Env.t -> + pattern_force:(unit -> unit) list ref -> + loc:Location.t -> + record_ty:type_expr -> + lbl_pat_list: + (Longident.t Location.loc * label_description * Typedtree.pattern * bool) + list -> + rest:Parsetree.record_pat_rest -> + enter_variable:(Location.t -> string Location.loc -> type_expr -> Ident.t) -> + unify_pat_types:(Location.t -> Env.t -> type_expr -> type_expr -> unit) -> + check_not_private:(Location.t -> type_expr -> type_declaration -> unit) -> + Typedtree.record_pat_rest + +val report_error : Format.formatter -> error -> unit diff --git a/compiler/ml/typedtree.ml b/compiler/ml/typedtree.ml index 74813efe3cb..5131e15f1d4 100644 --- a/compiler/ml/typedtree.ml +++ b/compiler/ml/typedtree.ml @@ -39,9 +39,7 @@ and record_pat_rest = { rest_ident: Ident.t; rest_name: string loc; rest_type: type_expr; - rest_path: Path.t; - rest_labels: Types.label_declaration list; - excluded_labels: string list; + excluded_runtime_labels: string list; } and pat_extra = diff --git a/compiler/ml/typedtree.mli b/compiler/ml/typedtree.mli index 939e46d1db6..61c4e6863c7 100644 --- a/compiler/ml/typedtree.mli +++ b/compiler/ml/typedtree.mli @@ -47,9 +47,7 @@ and record_pat_rest = { rest_ident: Ident.t; rest_name: string loc; rest_type: type_expr; - rest_path: Path.t; - rest_labels: Types.label_declaration list; - excluded_labels: string list; + excluded_runtime_labels: string list; } and pat_extra = diff --git a/compiler/syntax/src/res_ast_debugger.ml b/compiler/syntax/src/res_ast_debugger.ml index 0436254c07a..ab18be2a1df 100644 --- a/compiler/syntax/src/res_ast_debugger.ml +++ b/compiler/syntax/src/res_ast_debugger.ml @@ -804,7 +804,7 @@ module Sexp_ast = struct | None -> Sexp.atom "None" | Some p -> Sexp.list [Sexp.atom "Some"; pattern p]); ] - | Ppat_record (rows, flag, _rest) -> + | Ppat_record (rows, flag, rest) -> Sexp.list [ Sexp.atom "Ppat_record"; @@ -814,6 +814,21 @@ module Sexp_ast = struct ~f:(fun {lid = longident_loc; x = p} -> Sexp.list [longident longident_loc.Location.txt; pattern p]) rows); + (match rest with + | None -> Sexp.atom "None" + | Some {rest_name; rest_type; _} -> + Sexp.list + [ + Sexp.atom "Some"; + Sexp.list + [ + Sexp.atom rest_name.txt; + (match rest_type with + | None -> Sexp.atom "None" + | Some type_expr -> + Sexp.list [Sexp.atom "Some"; core_type type_expr]); + ]; + ]); ] | Ppat_array patterns -> Sexp.list diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index 3afb0cb5800..93a340af8fb 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -339,7 +339,7 @@ type fundef_parameter = type record_pattern_item = | PatUnderscore | PatField of Parsetree.pattern Parsetree.record_element - | PatRest of Parsetree.pattern + | PatRest of Parsetree.record_pat_rest type context = OrdinaryExpr | TernaryTrueBranchExpr | WhenExpr @@ -1544,22 +1544,25 @@ and parse_record_pattern_row p = Location.mkloc "_" (mk_loc name_start p.prev_end_pos) in let rest_loc = mk_loc start_pos p.prev_end_pos in - let rest_pat = - Ast_helper.Pat.constraint_ ~loc:rest_loc ~attrs - (Ast_helper.Pat.var ~loc:name.loc name) - core_type - in - Some (false, PatRest rest_pat)) + Some + ( false, + PatRest + {Parsetree.rest_loc; rest_name = name; rest_type = Some core_type} + )) else match p.Parser.token with | Lident ident -> (* ...name (no type annotation) *) Parser.next p; let loc = mk_loc start_pos p.prev_end_pos in - let rest_pat = - Ast_helper.Pat.var ~loc ~attrs (Location.mkloc ident loc) - in - Some (false, PatRest rest_pat) + Some + ( false, + PatRest + { + Parsetree.rest_loc = loc; + rest_name = Location.mkloc ident loc; + rest_type = None; + } ) | _ -> (* Fallback: treat as old-style spread (error) *) Some (true, PatField (parse_record_pattern_row_field ~attrs p))) @@ -1623,7 +1626,7 @@ and parse_record_pattern ~attrs p = match rest with | None -> (fields, flag, Some rest_pat) | Some _ -> - Parser.err ~start_pos:rest_pat.Parsetree.ppat_loc.loc_start p + Parser.err ~start_pos:rest_pat.Parsetree.rest_loc.loc_start p (Diagnostics.message Error_messages.record_pattern_multiple_rest); (fields, flag, rest)) | PatUnderscore -> (fields, flag, rest)) diff --git a/compiler/syntax/src/res_printer.ml b/compiler/syntax/src/res_printer.ml index 857404064e5..a1c1c631667 100644 --- a/compiler/syntax/src/res_printer.ml +++ b/compiler/syntax/src/res_printer.ml @@ -2807,18 +2807,16 @@ and print_pattern ~state (p : Parsetree.pattern) cmt_tbl = Doc.concat [Doc.lbrace; Doc.text "_"; Doc.rbrace] | Ppat_record (rows, open_flag, rest) -> let print_rest_pattern rest_pat = - match rest_pat.Parsetree.ppat_desc with - | Ppat_constraint ({ppat_desc = Ppat_var name}, typ) -> + match rest_pat.Parsetree.rest_type with + | Some typ -> Doc.concat [ Doc.text "..."; print_typ_expr ~state typ cmt_tbl; Doc.text " as "; - Doc.text name.txt; + Doc.text rest_pat.rest_name.txt; ] - | Ppat_var name -> Doc.concat [Doc.text "..."; Doc.text name.txt] - | _ -> - Doc.concat [Doc.text "..."; print_pattern ~state rest_pat cmt_tbl] + | None -> Doc.concat [Doc.text "..."; Doc.text rest_pat.rest_name.txt] in Doc.group (Doc.concat diff --git a/tests/syntax_tests/data/parsing/errors/other/expected/record_rest_duplicate.res.txt b/tests/syntax_tests/data/parsing/errors/other/expected/record_rest_duplicate.res.txt index c4c210586f3..dce00643948 100644 --- a/tests/syntax_tests/data/parsing/errors/other/expected/record_rest_duplicate.res.txt +++ b/tests/syntax_tests/data/parsing/errors/other/expected/record_rest_duplicate.res.txt @@ -8,4 +8,4 @@ Record patterns can only have one `...` rest clause. Use a single `...typeName as bindingName` clause to capture the remaining fields. -let { } = myRecord \ No newline at end of file +let { ...Config.t as second } = myRecord \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/errors/other/expected/spread.res.txt b/tests/syntax_tests/data/parsing/errors/other/expected/spread.res.txt index c75eaef1117..93a3f65fa05 100644 --- a/tests/syntax_tests/data/parsing/errors/other/expected/spread.res.txt +++ b/tests/syntax_tests/data/parsing/errors/other/expected/spread.res.txt @@ -69,7 +69,7 @@ Explanation: a list spread at the tail is efficient, but a spread in the middle let [|arr;_|] = [|1;2;3|] let record = { x with y } -let { } = myRecord +let { ...y } = myRecord let { M.t = t } = myRecord let x::y = myList type nonrec t = { diff --git a/tests/syntax_tests/data/parsing/grammar/pattern/expected/record.res.txt b/tests/syntax_tests/data/parsing/grammar/pattern/expected/record.res.txt index 5a18bd3fa1a..833c0bef89f 100644 --- a/tests/syntax_tests/data/parsing/grammar/pattern/expected/record.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/pattern/expected/record.res.txt @@ -81,15 +81,18 @@ let f [arity:1](({ a } : myRecord) as p) = () ;;for { a;_} = 0 to 10 do () done ;;for { a;_} = 0 to 10 do () done ;;for ({ a } : myRecord) = 0 to 10 do () done -let { a } = x -let { a } = x -let { a } = x -let { a; b } = x -;;match x with | { a } -> () | { a } -> () | { a } -> () -let f [arity:1]{ a } = () -let f [arity:1]{ a } = () -let f [arity:1]{ a } = () -let { a } = x -let { a } = x -let { a } = x -let { a } = x \ No newline at end of file +let { a; ...rest } = x +let { a; ...b as rest } = x +let { a; ...M.t as rest } = x +let { a; b; ...M.Sub.t as rest } = x +;;match x with + | { a; ...rest } -> () + | { a; ...b as rest } -> () + | { a; ...M.t as rest } -> () +let f [arity:1]{ a; ...rest } = () +let f [arity:1]{ a; ...b as rest } = () +let f [arity:1]{ a; ...M.t as rest } = () +let { a; ...'v t as rest } = x +let { a; ...'v M.t as rest } = x +let { a; ...int M.t as rest } = x +let { a; ...('a, 'b) M.t as rest } = x \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/recovery/pattern/expected/parenthesized.res.txt b/tests/syntax_tests/data/parsing/recovery/pattern/expected/parenthesized.res.txt index 62c41decb2f..426f716d65a 100644 --- a/tests/syntax_tests/data/parsing/recovery/pattern/expected/parenthesized.res.txt +++ b/tests/syntax_tests/data/parsing/recovery/pattern/expected/parenthesized.res.txt @@ -60,6 +60,6 @@ ;;match x with | a -> () | [|a;b|] -> () - | { a } -> () + | { a; ...b } -> () | 1::[] -> () | (1, 2) -> () \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/recovery/pattern/expected/record.res.txt b/tests/syntax_tests/data/parsing/recovery/pattern/expected/record.res.txt index 2cc87429258..8b332214d2b 100644 --- a/tests/syntax_tests/data/parsing/recovery/pattern/expected/record.res.txt +++ b/tests/syntax_tests/data/parsing/recovery/pattern/expected/record.res.txt @@ -9,4 +9,7 @@ Did you forget a `}` here? -;;match x with | { a; b = { x; y } } -> () | { y } -> () | { a; b } -> () \ No newline at end of file +;;match x with + | { a; b = { x; y } } -> () + | { y; ...x } -> () + | { a; b } -> () \ No newline at end of file From 53f864ca93d7ece84ab733eb05da29427b8a7134 Mon Sep 17 00:00:00 2001 From: tsnobip Date: Sun, 19 Apr 2026 10:58:12 +0200 Subject: [PATCH 20/22] stop ignoring _rest in a few more places --- analysis/src/dump_ast.ml | 19 ++++++- analysis/src/hint.ml | 7 ++- analysis/src/semantic_tokens.ml | 10 +++- tests/analysis_tests/tests/src/RecordRest.res | 5 ++ .../tests/src/expected/Highlight.res.txt | 2 +- .../tests/src/expected/RecordRest.res.txt | 55 ++++++++++++++++++- 6 files changed, 90 insertions(+), 8 deletions(-) diff --git a/analysis/src/dump_ast.ml b/analysis/src/dump_ast.ml index 6301af8f897..042c2be83f2 100644 --- a/analysis/src/dump_ast.ml +++ b/analysis/src/dump_ast.ml @@ -67,6 +67,14 @@ let print_core_type typ ~pos = | Ptyp_variant _ -> "Ptyp_variant()" | _ -> "" +let print_record_pattern_rest rest ~pos = + (rest.Parsetree.rest_name |> print_loc_denominator_loc ~pos) + ^ rest.rest_name.txt + ^ + match rest.rest_type with + | Some core_type -> " as " ^ print_core_type core_type ~pos + | None -> "" + let rec print_pattern pattern ~pos ~indentation = print_attributes pattern.Parsetree.ppat_attributes ^ (pattern.ppat_loc |> print_loc_denominator ~pos) @@ -101,7 +109,7 @@ let rec print_pattern pattern ~pos ~indentation = | None -> "" | Some pat -> "," ^ print_pattern pat ~pos ~indentation) ^ ")" - | Ppat_record (fields, _, _rest) -> + | Ppat_record (fields, _, rest) -> "Ppat_record(\n" ^ add_indentation (indentation + 1) ^ "fields:\n" @@ -112,6 +120,15 @@ let rec print_pattern pattern ~pos ~indentation = ^ ": " ^ print_pattern pat ~pos ~indentation:(indentation + 2)) |> String.concat "\n") + ^ + (match rest with + | None -> "" + | Some rest -> + "\n" + ^ add_indentation (indentation + 1) + ^ "rest:\n" + ^ add_indentation (indentation + 2) + ^ print_record_pattern_rest rest ~pos) ^ "\n" ^ add_indentation indentation ^ ")" diff --git a/analysis/src/hint.ml b/analysis/src/hint.ml index 3f9f8e98ff2..d8a7610d4d6 100644 --- a/analysis/src/hint.ml +++ b/analysis/src/hint.ml @@ -42,8 +42,11 @@ let inlay ~source ~kind_file ~pos ~max_length ~full ~state ~debug = let rec process_pattern (pat : Parsetree.pattern) = match pat.ppat_desc with | Ppat_tuple pl -> pl |> List.iter process_pattern - | Ppat_record (fields, _, _rest) -> - Ext_list.iter fields (fun {x = p} -> process_pattern p) + | Ppat_record (fields, _, rest) -> + Ext_list.iter fields (fun {x = p} -> process_pattern p); + (match rest with + | Some {rest_name; _} -> push rest_name.loc Type + | None -> ()) | Ppat_array fields -> fields |> List.iter process_pattern | Ppat_var {loc} -> push loc Type | _ -> () diff --git a/analysis/src/semantic_tokens.ml b/analysis/src/semantic_tokens.ml index bb230f1c7a2..8a0bda9dc82 100644 --- a/analysis/src/semantic_tokens.ml +++ b/analysis/src/semantic_tokens.ml @@ -233,9 +233,13 @@ let command ~debug ~emitter ~source ~kind_file = | Ppat_construct ({txt = Lident ("true" | "false")}, _) -> (* Don't emit true or false *) Ast_iterator.default_iterator.pat iterator p - | Ppat_record (cases, _, _rest) -> + | Ppat_record (cases, _, rest) -> Ext_list.iter cases (fun {lid = label} -> emitter |> emit_record_label ~label ~debug); + (match rest with + | Some {rest_name = {txt = id; loc}; _} when is_lowercase_id id -> + emitter |> emit_variable ~id ~debug ~loc + | _ -> ()); Ast_iterator.default_iterator.pat iterator p | Ppat_construct (name, _) -> emitter |> emit_variant ~name ~debug; @@ -490,7 +494,7 @@ let command ~debug ~emitter ~source ~kind_file = in let {Res_driver.parsetree = structure; diagnostics} = parser ~source in if debug then - Printf.printf "structure items:%d diagnostics:%d \n" + Printf.printf "structure items:%d diagnostics:%d\n" (List.length structure) (List.length diagnostics); iterator.structure iterator structure |> ignore) else @@ -499,7 +503,7 @@ let command ~debug ~emitter ~source ~kind_file = in let {Res_driver.parsetree = signature; diagnostics} = parser ~source in if debug then - Printf.printf "signature items:%d diagnostics:%d \n" + Printf.printf "signature items:%d diagnostics:%d\n" (List.length signature) (List.length diagnostics); iterator.signature iterator signature |> ignore diff --git a/tests/analysis_tests/tests/src/RecordRest.res b/tests/analysis_tests/tests/src/RecordRest.res index 6e7dd0d2a52..54e3eb86b43 100644 --- a/tests/analysis_tests/tests/src/RecordRest.res +++ b/tests/analysis_tests/tests/src/RecordRest.res @@ -9,3 +9,8 @@ let getVersion = (config: config) => rest.version // ^def } + +let {name: _, ...SubConfig.t as localRest} = {name: "v", version: "1"} + +//^hin +//^hig diff --git a/tests/analysis_tests/tests/src/expected/Highlight.res.txt b/tests/analysis_tests/tests/src/expected/Highlight.res.txt index 6ee7e2e8005..e5d7089af19 100644 --- a/tests/analysis_tests/tests/src/expected/Highlight.res.txt +++ b/tests/analysis_tests/tests/src/expected/Highlight.res.txt @@ -1,5 +1,5 @@ Highlight src/Highlight.res -structure items:39 diagnostics:0 +structure items:39 diagnostics:0 Lident: M 0:7 Namespace Lident: C 1:9 Namespace Lident: Component 1:13 Namespace diff --git a/tests/analysis_tests/tests/src/expected/RecordRest.res.txt b/tests/analysis_tests/tests/src/expected/RecordRest.res.txt index 67434a6c3f2..ead063dceda 100644 --- a/tests/analysis_tests/tests/src/expected/RecordRest.res.txt +++ b/tests/analysis_tests/tests/src/expected/RecordRest.res.txt @@ -1,2 +1,55 @@ Definition src/RecordRest.res 8:4 -{"uri": "RecordRest.res", "range": {"start": {"line": 7, "character": 32}, "end": {"line": 7, "character": 36}}} +{ + "range": { + "end": { "character": 36, "line": 7 }, + "start": { "character": 32, "line": 7 } + }, + "uri": "file:///RecordRest.res" +} + +Inlay Hint src/RecordRest.res 1:34 +[ + { + "kind": 1, + "label": ": SubConfig.t", + "paddingLeft": true, + "paddingRight": false, + "position": { "character": 41, "line": 12 } + }, + { + "kind": 1, + "label": ": config => string", + "paddingLeft": true, + "paddingRight": false, + "position": { "character": 14, "line": 5 } + } +] + +Highlight src/RecordRest.res +structure items:4 diagnostics:0 +Lident: config 0:5 Type +Lident: name 0:15 Property +Lident: string 0:21 Type +Lident: version 0:29 Property +Lident: string 0:38 Type +Lident: SubConfig 1:7 Namespace +Lident: t 2:7 Type +Lident: version 2:12 Property +Lident: string 2:21 Type +Variable: getVersion [5:4->5:14] +Variable: config [5:18->5:24] +Lident: config 5:26 Type +Lident: config 6:9 Variable +Lident: name 7:5 Property +Variable: rest [7:32->7:36] +Ldot: SubConfig 7:17 Namespace +Lident: t 7:27 Type +Lident: version 8:9 Property +Lident: rest 8:4 Variable +Lident: name 12:5 Property +Variable: localRest [12:32->12:41] +Ldot: SubConfig 12:17 Namespace +Lident: t 12:27 Type +Lident: name 12:46 Property +Lident: version 12:57 Property + From e0c41c83174dac3f1b871f47ac10c5de699e057b Mon Sep 17 00:00:00 2001 From: tsnobip Date: Tue, 16 Jun 2026 17:49:29 +0200 Subject: [PATCH 21/22] format Signed-off-by: tsnobip --- analysis/src/dump_ast.ml | 17 ++++++++--------- analysis/src/hint.ml | 4 ++-- compiler/ml/typecore.ml | 2 +- 3 files changed, 11 insertions(+), 12 deletions(-) diff --git a/analysis/src/dump_ast.ml b/analysis/src/dump_ast.ml index 042c2be83f2..19b45e07f2a 100644 --- a/analysis/src/dump_ast.ml +++ b/analysis/src/dump_ast.ml @@ -120,15 +120,14 @@ let rec print_pattern pattern ~pos ~indentation = ^ ": " ^ print_pattern pat ~pos ~indentation:(indentation + 2)) |> String.concat "\n") - ^ - (match rest with - | None -> "" - | Some rest -> - "\n" - ^ add_indentation (indentation + 1) - ^ "rest:\n" - ^ add_indentation (indentation + 2) - ^ print_record_pattern_rest rest ~pos) + ^ (match rest with + | None -> "" + | Some rest -> + "\n" + ^ add_indentation (indentation + 1) + ^ "rest:\n" + ^ add_indentation (indentation + 2) + ^ print_record_pattern_rest rest ~pos) ^ "\n" ^ add_indentation indentation ^ ")" diff --git a/analysis/src/hint.ml b/analysis/src/hint.ml index d8a7610d4d6..49b290089bc 100644 --- a/analysis/src/hint.ml +++ b/analysis/src/hint.ml @@ -42,9 +42,9 @@ let inlay ~source ~kind_file ~pos ~max_length ~full ~state ~debug = let rec process_pattern (pat : Parsetree.pattern) = match pat.ppat_desc with | Ppat_tuple pl -> pl |> List.iter process_pattern - | Ppat_record (fields, _, rest) -> + | Ppat_record (fields, _, rest) -> ( Ext_list.iter fields (fun {x = p} -> process_pattern p); - (match rest with + match rest with | Some {rest_name; _} -> push rest_name.loc Type | None -> ()) | Ppat_array fields -> fields |> List.iter process_pattern diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index f70e3159037..8bb9c672ddc 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -5098,7 +5098,7 @@ let report_error env loc ppf error = with @{taggedTemplate<...>@} instead of using the removed \ @{@@taggedTemplate@} decorator.@,\ \ - To use a ReScript function as a tag, lift it with \ - @{TaggedTemplate.make@}.@]" + @{TaggedTemplate.make@}.@]" type_expr typ | Record_rest err -> Typecore_record_rest.report_error ppf err From dbe99a216322f21d7d7f3f9bc11c24d50fed8653 Mon Sep 17 00:00:00 2001 From: tsnobip Date: Tue, 16 Jun 2026 18:00:46 +0200 Subject: [PATCH 22/22] improve output (compile to JS destructuring) --- compiler/core/j.ml | 38 +++- compiler/core/js_analyzer.ml | 15 +- compiler/core/js_dump.ml | 105 ++++++++-- compiler/core/js_exp_make.ml | 6 + compiler/core/js_exp_make.mli | 2 + compiler/core/js_fold.ml | 25 ++- .../core/js_pass_flatten_and_mark_dead.ml | 49 +++-- compiler/core/js_pass_record_rest.ml | 193 ++++++++++++++++++ compiler/core/js_pass_scope.ml | 93 +++++---- compiler/core/js_pass_tailcall_inline.ml | 15 +- compiler/core/js_record_fold.ml | 20 +- compiler/core/js_record_iter.ml | 16 +- compiler/core/js_record_map.ml | 25 ++- compiler/core/lam_compile_main.cppo.ml | 2 + compiler/core/lam_compile_primitive.ml | 26 +-- rewatch/tests/snapshots/rename-file.txt | 1 - .../record_rest_empty_warning.res.expected | 4 +- .../record_rest_private_type.res.expected | 6 +- tests/tests/src/record_rest_test.mjs | 114 ++++++----- tests/tests/src/record_rest_test.res | 2 + .../src/expected/ZRecordRest.res.jsout | 5 +- 21 files changed, 603 insertions(+), 159 deletions(-) create mode 100644 compiler/core/js_pass_record_rest.ml diff --git a/compiler/core/j.ml b/compiler/core/j.ml index f20b22ec727..644756665fe 100644 --- a/compiler/core/j.ml +++ b/compiler/core/j.ml @@ -77,6 +77,18 @@ and property_map = (property_name * expression) list and length_object = Js_op.length_object and delim = External_arg_spec.delim = DNone | DStarJ | DNoQuotes | DBackQuotes +and record_rest_field = { + record_rest_label: string; + record_rest_ident: ident option; +} + +and object_rest_param = { + object_rest_fields: record_rest_field list; + object_rest_rest: ident; +} + +and param = Ident_param of ident | Object_rest_param of object_rest_param + and expression_desc = | Length of expression * length_object | Is_null_or_undefined of expression (** where we use a trick [== null ] *) @@ -132,7 +144,7 @@ and expression_desc = | Var of vident | Fun of { is_method: bool; - params: ident list; + params: param list; body: block; env: Js_fun_env.t; return_unit: bool; @@ -165,6 +177,7 @@ and expression_desc = | Null | Await of expression | Spread of expression + | Record_rest of record_rest_field list * expression and for_ident_expression = expression (* pure*) @@ -327,6 +340,9 @@ and deps_program = { finish_ident_expression; property_map; length_object; + record_rest_field; + object_rest_param; + param; (* for_ident; *) required_modules; case_clause; @@ -337,3 +353,23 @@ FIXME: customize for each code generator for each code generator, we can provide a white-list so that we can achieve the optimal *) + +let record_rest_field_idents fields = + List.filter_map (fun {record_rest_ident} -> record_rest_ident) fields + +let object_rest_param_idents {object_rest_fields; object_rest_rest} = + object_rest_rest :: record_rest_field_idents object_rest_fields + +let param_idents = function + | Ident_param id -> [id] + | Object_rest_param param -> object_rest_param_idents param + +let params_idents params = List.concat_map param_idents params + +let params_as_idents params = + let rec aux acc = function + | [] -> Some (List.rev acc) + | Ident_param id :: rest -> aux (id :: acc) rest + | Object_rest_param _ :: _ -> None + in + aux [] params diff --git a/compiler/core/js_analyzer.ml b/compiler/core/js_analyzer.ml index 25852412667..e51552d772d 100644 --- a/compiler/core/js_analyzer.ml +++ b/compiler/core/js_analyzer.ml @@ -30,6 +30,14 @@ type idents_stats = { let add_defined_idents (x : idents_stats) ident = x.defined_idents <- Set_ident.add x.defined_idents ident +let add_record_rest_field_idents stats fields = + List.iter + (fun (field : J.record_rest_field) -> + match field.record_rest_ident with + | None -> () + | Some ident -> add_defined_idents stats ident) + fields + (* Assume that functions already calculated closure correctly Maybe in the future, we should add a dirty flag, to mark the calcuated closure is correct or not @@ -46,6 +54,9 @@ let free_variables (stats : idents_stats) = (fun self st -> add_defined_idents stats st.ident; match st.value with + | Some {expression_desc = Record_rest (fields, source)} -> + add_record_rest_field_idents stats fields; + self.expression self source | None -> () | Some v -> self.expression self v); ident = @@ -118,6 +129,7 @@ let rec no_side_effect_expression_desc (x : J.expression_desc) = | FlatCall _ | Call _ | New _ | Raw_js_code _ (* actually true? *) -> false | Await _ -> false | Spread _ -> false + | Record_rest _ -> false and no_side_effect (x : J.expression) = no_side_effect_expression_desc x.expression_desc @@ -230,7 +242,8 @@ let rec eq_expression ({expression_desc = x0} : J.expression) | _ -> false) | Length _ | Is_null_or_undefined _ | String_append _ | Typeof _ | Js_not _ | Js_bnot _ | In _ | Cond _ | FlatCall _ | New _ | Fun _ | Raw_js_code _ - | Array _ | Caml_block_tag _ | Object _ | Tagged_template _ | Await _ -> + | Array _ | Caml_block_tag _ | Object _ | Tagged_template _ | Await _ + | Record_rest _ -> false | Spread _ -> false diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index 6f6da8b605c..1ceb8615867 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -172,6 +172,7 @@ let rec exp_need_paren ?(arrow = false) (e : J.expression) = | Await _ -> false | Spread _ -> false | Tagged_template _ -> false + | Record_rest _ -> false | Optional_block (e, true) when arrow -> exp_need_paren ~arrow e | Optional_block _ -> false @@ -237,7 +238,43 @@ let debugger_nl f = semi f; P.newline f -let formal_parameter_list cxt f l = iter_lst cxt f l Ext_pp_scope.ident comma_sp +let rec record_rest_field cxt f + ({record_rest_label; record_rest_ident} : J.record_rest_field) = + let key = Js_dump_property.property_key (Lit record_rest_label) in + match record_rest_ident with + | None -> + P.string f key; + cxt + | Some id -> + let str, cxt = Ext_pp_scope.str_of_ident cxt id in + if key = str then P.string f key + else ( + P.string f key; + P.string f L.colon_space; + P.string f str); + cxt + +and record_rest_pattern cxt f fields rest = + P.string f "{"; + let cxt = + match fields with + | [] -> cxt + | _ -> + let cxt = iter_lst cxt f fields record_rest_field comma_sp in + comma_sp f; + cxt + in + P.string f "..."; + let cxt = Ext_pp_scope.ident cxt f rest in + P.string f "}"; + cxt + +and param cxt f = function + | J.Ident_param id -> Ext_pp_scope.ident cxt f id + | Object_rest_param {object_rest_fields; object_rest_rest} -> + record_rest_pattern cxt f object_rest_fields object_rest_rest + +and formal_parameter_list cxt f l = iter_lst cxt f l param comma_sp (* IdentMap *) (* @@ -269,6 +306,20 @@ let is_var (b : J.expression) a = | Var (Id i) -> Ident.same i a | _ -> false +let params_match_call params args fn = + match J.params_as_idents params with + | Some params -> ( + Ext_list.for_all2_no_exn args params is_var + && + match fn with + (* This check is needed to avoid some edge cases + {[function(x){return x(x)}]} + here the function is also called `x` + *) + | J.Id id -> not (Ext_list.exists params (fun x -> Ident.same x id)) + | Qualified _ -> true) + | None -> false + type fn_exp_state = | Is_return (* for sure no name *) | Name_top of Ident.t @@ -286,7 +337,7 @@ let rec try_optimize_curry cxt f len function_id = P.paren_group f 1 (fun _ -> expression ~level:1 cxt f function_id) and pp_function ~return_unit ~async ~is_method ?directive cxt (f : P.t) - ~fn_state (l : Ident.t list) (b : J.block) (env : Js_fun_env.t) : cxt = + ~fn_state (l : J.param list) (b : J.block) (env : Js_fun_env.t) : cxt = match b with | [ { @@ -309,16 +360,7 @@ and pp_function ~return_unit ~async ~is_method ?directive cxt (f : P.t) {[ function(x,y){ return u(x,y) } ]} it can be optimized in to either [u] or [Curry.__n(u)] *) - (not is_method) - && Ext_list.for_all2_no_exn ls l is_var - && - match v with - (* This check is needed to avoid some edge cases - {[function(x){return x(x)}]} - here the function is also called `x` - *) - | Id id -> not (Ext_list.exists l (fun x -> Ident.same x id)) - | Qualified _ -> true -> ( + (not is_method) && params_match_call l ls v -> ( let optimize len ~p cxt f v = if p then try_optimize_curry cxt f len function_id else vident cxt f v in @@ -359,10 +401,10 @@ and pp_function ~return_unit ~async ~is_method ?directive cxt (f : P.t) *) let inner_cxt = Ext_pp_scope.sub_scope outer_cxt set_env in let param_body () : unit = - if is_method then ( + if is_method then match l with | [] -> assert false - | this :: arguments -> + | Ident_param this :: arguments -> let cxt = P.paren_group f 1 (fun _ -> formal_parameter_list inner_cxt f arguments) @@ -373,11 +415,13 @@ and pp_function ~return_unit ~async ~is_method ?directive cxt (f : P.t) if Js_fun_env.get_unused env 0 then cxt else pp_var_assign_this cxt f this in - function_body ?directive ~return_unit cxt f b)) + function_body ?directive ~return_unit cxt f b) + | Object_rest_param _ :: _ -> assert false else let cxt = match l with - | [single] when arrow -> Ext_pp_scope.ident inner_cxt f single + | [Ident_param single] when arrow -> + Ext_pp_scope.ident inner_cxt f single | l -> P.paren_group f 1 (fun _ -> formal_parameter_list inner_cxt f l) in @@ -494,6 +538,25 @@ and expression_desc cxt ~(level : int) f x : cxt = P.string f L.undefined; cxt | Var v -> vident cxt f v + | Record_rest (fields, source) -> + P.cond_paren_group f (level > 15) (fun _ -> + P.string f "(({"; + fields + |> List.iteri (fun i ({record_rest_label; _} : J.record_rest_field) -> + if i > 0 then comma_sp f; + let key = + Js_dump_property.property_key (Lit record_rest_label) + in + P.string f key; + P.string f L.colon_space; + P.string f ("__unused" ^ string_of_int i)); + (match fields with + | [] -> () + | _ -> comma_sp f); + P.string f "...__rest}) => __rest)("; + let cxt = expression ~level:0 cxt f source in + P.string f ")"; + cxt) | Bool b -> bool f b; cxt @@ -1294,6 +1357,16 @@ and variable_declaration top cxt f (variable : J.variable_declaration) : cxt = pp_function ?directive ~is_method ~return_unit ~async ~fn_state:(if top then Name_top name else Name_non_top name) cxt f params body env + | Record_rest (fields, source) -> + P.string f L.let_; + P.space f; + let cxt = record_rest_pattern cxt f fields name in + P.space f; + P.string f L.eq; + P.space f; + let cxt = expression ~level:1 cxt f source in + semi f; + cxt | _ -> let cxt = pp_var_assign cxt f name in let cxt = expression ~level:1 cxt f e in diff --git a/compiler/core/js_exp_make.ml b/compiler/core/js_exp_make.ml index 530765477ed..711ce215e4b 100644 --- a/compiler/core/js_exp_make.ml +++ b/compiler/core/js_exp_make.ml @@ -166,6 +166,10 @@ let raw_js_code ?comment info s : t = } let array ?comment mt es : t = {expression_desc = Array (es, mt); comment} + +let record_rest ?comment fields source : t = + {expression_desc = Record_rest (fields, source); comment} + let some_comment = None let optional_block e : J.expression = @@ -239,6 +243,7 @@ let ocaml_fun ?comment ?immutable_mask ?directive ~return_unit ~async ~one_unit_arg params body : t = let params = if one_unit_arg then [] else params in let len = List.length params in + let params = List.map (fun id -> J.Ident_param id) params in { expression_desc = Fun @@ -256,6 +261,7 @@ let ocaml_fun ?comment ?immutable_mask ?directive ~return_unit ~async let method_ ?comment ?immutable_mask ~async ~return_unit params body : t = let len = List.length params in + let params = List.map (fun id -> J.Ident_param id) params in { expression_desc = Fun diff --git a/compiler/core/js_exp_make.mli b/compiler/core/js_exp_make.mli index d37d55ea9a8..84ffed98d61 100644 --- a/compiler/core/js_exp_make.mli +++ b/compiler/core/js_exp_make.mli @@ -97,6 +97,8 @@ val runtime_ref : string -> string -> t val str : ?delim:J.delim -> ?comment:string -> string -> t +val record_rest : ?comment:string -> J.record_rest_field list -> t -> t + val ocaml_fun : ?comment:string -> ?immutable_mask:bool array -> diff --git a/compiler/core/js_fold.ml b/compiler/core/js_fold.ml index e080f501196..25280fa0e7e 100644 --- a/compiler/core/js_fold.ml +++ b/compiler/core/js_fold.ml @@ -83,6 +83,26 @@ class fold = method length_object : length_object -> 'self_type = unknown _self + method record_rest_field : record_rest_field -> 'self_type = + fun {record_rest_ident = _x0; _} -> + let _self = option (fun _self -> _self#ident) _self _x0 in + _self + + method object_rest_param : object_rest_param -> 'self_type = + fun {object_rest_fields = _x0; object_rest_rest = _x1} -> + let _self = list (fun _self -> _self#record_rest_field) _self _x0 in + let _self = _self#ident _x1 in + _self + + method param : param -> 'self_type = + function + | Ident_param _x0 -> + let _self = _self#ident _x0 in + _self + | Object_rest_param _x0 -> + let _self = _self#object_rest_param _x0 in + _self + method expression_desc : expression_desc -> 'self_type = function | Length (_x0, _x1) -> @@ -159,7 +179,7 @@ class fold = let _self = _self#vident _x0 in _self | Fun {params = x1; body = x2} -> - let _self = list (fun _self -> _self#ident) _self x1 in + let _self = list (fun _self -> _self#param) _self x1 in let _self = _self#block x2 in _self | Str _ -> _self @@ -190,6 +210,9 @@ class fold = | Spread _x0 -> let _self = _self#expression _x0 in _self + | Record_rest (_x0, _x1) -> + let _self = _self#expression _x1 in + _self method for_ident_expression : for_ident_expression -> 'self_type = _self#expression diff --git a/compiler/core/js_pass_flatten_and_mark_dead.ml b/compiler/core/js_pass_flatten_and_mark_dead.ml index 30424e68abd..22c0592e346 100644 --- a/compiler/core/js_pass_flatten_and_mark_dead.ml +++ b/compiler/core/js_pass_flatten_and_mark_dead.ml @@ -29,6 +29,14 @@ type meta_info = Info of J.ident_info | Recursive let super = Js_record_iter.super +let add_binding_info ident_use_stats ident_info ident = + match Hash_ident.find_opt ident_use_stats ident with + | Some Recursive -> + Js_op_util.update_used_stats ident_info Used; + Hash_ident.replace ident_use_stats ident (Info ident_info) + | Some (Info _) -> () + | None -> Hash_ident.add ident_use_stats ident (Info ident_info) + let mark_dead_code (js : J.program) : J.program = let ident_use_stats : meta_info Hash_ident.t = Hash_ident.create 17 in let mark_dead = @@ -64,21 +72,32 @@ let mark_dead_code (js : J.program) : J.program = if Set_ident.mem js.export_set ident then Js_op_util.update_used_stats ident_info Exported in - match Hash_ident.find_opt ident_use_stats ident with - | Some Recursive -> - Js_op_util.update_used_stats ident_info Used; - Hash_ident.replace ident_use_stats ident (Info ident_info) - | Some (Info _) -> - (* check [camlinternlFormat,box_type] inlined twice - FIXME: seems we have redeclared identifiers - *) - () - (* assert false *) - | None -> - (* First time *) - Hash_ident.add ident_use_stats ident (Info ident_info); - Js_op_util.update_used_stats ident_info - (if pure then Scanning_pure else Scanning_non_pure))); + let () = + match Hash_ident.find_opt ident_use_stats ident with + | Some Recursive -> + Js_op_util.update_used_stats ident_info Used; + Hash_ident.replace ident_use_stats ident (Info ident_info) + | Some (Info _) -> + (* check [camlinternlFormat,box_type] inlined twice + FIXME: seems we have redeclared identifiers + *) + () + (* assert false *) + | None -> + (* First time *) + Hash_ident.add ident_use_stats ident (Info ident_info); + Js_op_util.update_used_stats ident_info + (if pure then Scanning_pure else Scanning_non_pure) + in + match value with + | Some {expression_desc = Record_rest (fields, _)} -> + fields + |> List.iter (fun (field : J.record_rest_field) -> + match field.record_rest_ident with + | None -> () + | Some ident -> + add_binding_info ident_use_stats ident_info ident) + | _ -> ())); } in mark_dead.program mark_dead js; diff --git a/compiler/core/js_pass_record_rest.ml b/compiler/core/js_pass_record_rest.ml new file mode 100644 index 00000000000..2d5a60c30e9 --- /dev/null +++ b/compiler/core/js_pass_record_rest.ml @@ -0,0 +1,193 @@ +module E = Js_exp_make +open J + +let field_ident_name i label = + if Js_dump_property.property_key (Lit label) = label then label + else "__rest_field" ^ string_of_int i + +let ignored_ident i = Ext_ident.create ("__unused" ^ string_of_int i) + +let uses_ident ident block = + let found = ref false in + let obj = + { + Js_record_iter.super with + ident = + (fun _ candidate -> if Ident.same ident candidate then found := true); + } + in + obj.block obj block; + !found + +let materialize_fields source fields tail = + match source.J.expression_desc with + | Var (Id source_ident) -> + let used_fields = Hashtbl.create 7 in + let field_names = + List.mapi (fun i field -> (field.J.record_rest_label, i)) fields + in + let find_field_index label = List.assoc_opt label field_names in + let get_field_ident label = + match Hashtbl.find_opt used_fields label with + | Some ident -> ident + | None -> + let i = + match find_field_index label with + | Some i -> i + | None -> assert false + in + let ident = Ext_ident.create (field_ident_name i label) in + Hashtbl.add used_fields label ident; + ident + in + let replace = + { + Js_record_map.super with + expression = + (fun self expr -> + match expr.expression_desc with + | Static_index ({expression_desc = Var (Id ident); _}, label, _) + when Ident.same ident source_ident + && find_field_index label <> None -> + E.var (get_field_ident label) + | _ -> Js_record_map.super.expression self expr); + } + in + let tail = replace.block replace tail in + let fields = + List.mapi + (fun i field -> + match field.J.record_rest_ident with + | Some _ -> field + | None -> + let ident = + match Hashtbl.find_opt used_fields field.record_rest_label with + | Some ident -> ident + | None -> ignored_ident i + in + {field with record_rest_ident = Some ident}) + fields + in + (fields, tail) + | _ -> + let fields = + List.mapi + (fun i field -> + match field.J.record_rest_ident with + | Some _ -> field + | None -> {field with record_rest_ident = Some (ignored_ident i)}) + fields + in + (fields, tail) + +let pass = + let super = Js_record_map.super in + let block (self : Js_record_map.iter) = function + | ({ + statement_desc = + Variable + ({ + value = + Some + ({expression_desc = Record_rest (fields, source); _} as + value); + _; + } as variable); + _; + } as statement) + :: tail -> + let source = self.expression self source in + let tail = self.block self tail in + let fields, tail = materialize_fields source fields tail in + { + statement with + statement_desc = + Variable + { + variable with + value = + Some {value with expression_desc = Record_rest (fields, source)}; + }; + } + :: tail + | statement :: tail -> self.statement self statement :: self.block self tail + | [] -> [] + in + { + super with + block; + expression = + (fun self expr -> + match expr.expression_desc with + | Fun ({is_method = false; params = [Ident_param param]; body} as fun_) + -> + let body = self.block self body in + let params, body = + match body with + | { + statement_desc = + Variable + { + ident = rest; + value = + Some + { + expression_desc = + Record_rest + (fields, {expression_desc = Var (Id source); _}); + _; + }; + _; + }; + _; + } + :: tail + when Ident.name param = "param" + && Ident.same param source + && not (uses_ident param tail) -> + ( [ + Object_rest_param + {object_rest_fields = fields; object_rest_rest = rest}; + ], + tail ) + | [ + { + statement_desc = + Return + ({ + expression_desc = + Record_rest + ( fields, + ({expression_desc = Var (Id source); _} as + source_expr) ); + _; + } as rest_expr); + _; + }; + ] + when Ident.name param = "param" && Ident.same param source -> + let rest = Ext_ident.create "rest" in + let fields, body = + materialize_fields source_expr fields + [ + { + statement_desc = Return (E.var rest); + comment = rest_expr.comment; + }; + ] + in + ( [ + Object_rest_param + {object_rest_fields = fields; object_rest_rest = rest}; + ], + body ) + | _ -> (fun_.params, body) + in + {expr with expression_desc = Fun {fun_ with params; body}} + | Fun ({body} as fun_) -> + let body = self.block self body in + {expr with expression_desc = Fun {fun_ with body}} + | _ -> super.expression self expr); + } + +let program program = pass.program pass program diff --git a/compiler/core/js_pass_scope.ml b/compiler/core/js_pass_scope.ml index 004f3e5b040..b246e43fbc0 100644 --- a/compiler/core/js_pass_scope.ml +++ b/compiler/core/js_pass_scope.ml @@ -129,6 +129,8 @@ let add_defined_ident (st : state) id = let add_used_ident (st : state) id = {st with used_idents = Set_ident.add st.used_idents id} +let add_defined_idents st ids = List.fold_left add_defined_ident st ids + let super = Js_record_fold.super let record_scope_pass = @@ -146,14 +148,17 @@ let record_scope_pass = *) (* Note that [used_idents] is not complete it ignores some locally defined idents *) - let param_set = Set_ident.of_list params in + let param_idents = J.params_idents params in + let param_set = Set_ident.of_list param_idents in let {defined_idents = defined_idents'; used_idents = used_idents'} = + let mutable_params = + match J.params_as_idents params with + | None -> Set_ident.empty + | Some params -> + Set_ident.of_list (Js_fun_env.get_mutable_params params env) + in self.block self - { - init_state with - mutable_values = - Set_ident.of_list (Js_fun_env.get_mutable_params params env); - } + {init_state with mutable_values = mutable_params} body in (* let defined_idents', used_idents' = @@ -161,8 +166,12 @@ let record_scope_pass = (* mark which param is used *) params |> List.iteri (fun i v -> - if not (Set_ident.mem used_idents' v) then - Js_fun_env.mark_unused env i); + if + not + (List.exists + (fun ident -> Set_ident.mem used_idents' ident) + (J.param_idents v)) + then Js_fun_env.mark_unused env i); let closured_idents' = (* pass param_set down *) Set_ident.(diff used_idents' (union defined_idents' param_set)) @@ -189,25 +198,32 @@ let record_scope_pass = (fun self state x -> match x with | {ident; value; property} -> ( + let record_rest_idents = + match value with + | Some {expression_desc = Record_rest (fields, _)} -> + J.record_rest_field_idents fields + | _ -> [] + in let obj = - add_defined_ident - (match (state.in_loop, property) with - | true, Variable -> add_loop_mutable_variable state ident - | true, (Strict | StrictOpt | Alias) - (* Not real true immutable in javascript + add_defined_idents + (add_defined_ident + (match (state.in_loop, property) with + | true, Variable -> add_loop_mutable_variable state ident + | true, (Strict | StrictOpt | Alias) + (* Not real true immutable in javascript since it's in the loop TODO: we should also *) - -> ( - match value with - | None -> - add_loop_mutable_variable state ident - (* TODO: Check why assertion failure *) - (* self#add_loop_mutable_variable ident *) - (* assert false *) - | Some x -> ( - (* + -> ( + match value with + | None -> + add_loop_mutable_variable state ident + (* TODO: Check why assertion failure *) + (* self#add_loop_mutable_variable ident *) + (* assert false *) + | Some x -> ( + (* when x is an immediate immutable value, (like integer .. ) not a reference, it should be Immutable @@ -215,22 +231,23 @@ let record_scope_pass = type system might help here TODO: *) - match x.expression_desc with - | Fun _ | Number _ | Str _ -> state - | _ -> - (* if Set_ident.(is_empty @@ *) - (* inter self#get_mutable_values *) - (* ( ({< *) - (* defined_idents = Set_ident.empty; *) - (* used_idents = Set_ident.empty; *) - (* >} # expression x) # get_used_idents)) then *) - (* (\* FIXME: still need to check expression is pure or not*\) *) - (* self *) - (* else *) - add_loop_mutable_variable state ident)) - | false, Variable -> add_mutable_variable state ident - | false, (Strict | StrictOpt | Alias) -> state) - ident + match x.expression_desc with + | Fun _ | Number _ | Str _ -> state + | _ -> + (* if Set_ident.(is_empty @@ *) + (* inter self#get_mutable_values *) + (* ( ({< *) + (* defined_idents = Set_ident.empty; *) + (* used_idents = Set_ident.empty; *) + (* >} # expression x) # get_used_idents)) then *) + (* (\* FIXME: still need to check expression is pure or not*\) *) + (* self *) + (* else *) + add_loop_mutable_variable state ident)) + | false, Variable -> add_mutable_variable state ident + | false, (Strict | StrictOpt | Alias) -> state) + ident) + record_rest_idents in match value with | None -> obj diff --git a/compiler/core/js_pass_tailcall_inline.ml b/compiler/core/js_pass_tailcall_inline.ml index 5a92b05cac1..b60b4cf8919 100644 --- a/compiler/core/js_pass_tailcall_inline.ml +++ b/compiler/core/js_pass_tailcall_inline.ml @@ -78,6 +78,11 @@ let inline_call (immutable_list : bool list) params (args : J.expression list) let obj = substitue_variables map in obj.block obj block +let simple_params_exn params = + match J.params_as_idents params with + | Some params -> params + | None -> assert false + (** There is a side effect when traversing dead code, since we assume that substitue a node would mark a node as dead node, @@ -182,13 +187,16 @@ let subst (export_set : Set_ident.t) stats = ident_info = {used_stats = Once_pure}; ident = _; } as v) - when Ext_list.same_length params args -> + when match J.params_as_idents params with + | Some params -> Ext_list.same_length params args + | None -> false -> Js_op_util.update_used_stats v.ident_info Dead_pure; let no_tailcall = Js_fun_env.no_tailcall env in let processed_blocks = self.block self body (* see #278 before changes*) in + let params = simple_params_exn params in inline_call no_tailcall params args processed_blocks (* Ext_list.fold_right2 params args processed_blocks @@ -222,12 +230,15 @@ let subst (export_set : Set_ident.t) stats = }; }; ] - when Ext_list.same_length params args -> + when match J.params_as_idents params with + | Some params -> Ext_list.same_length params args + | None -> false -> let no_tailcall = Js_fun_env.no_tailcall env in let processed_blocks = self.block self body (* see #278 before changes*) in + let params = simple_params_exn params in inline_call no_tailcall params args processed_blocks | x :: xs -> self.statement self x :: self.block self xs | [] -> []); diff --git a/compiler/core/js_record_fold.ml b/compiler/core/js_record_fold.ml index d3e0de74358..994ca79b177 100644 --- a/compiler/core/js_record_fold.ml +++ b/compiler/core/js_record_fold.ml @@ -89,6 +89,21 @@ let property_map : 'a. ('a, property_map) fn = let length_object : 'a. ('a, length_object) fn = unknown +let record_rest_field : 'a. ('a, record_rest_field) fn = + fun _self st {record_rest_ident; _} -> + option _self.ident _self st record_rest_ident + +let object_rest_param : 'a. ('a, object_rest_param) fn = + fun _self st {object_rest_fields; object_rest_rest} -> + let st = list record_rest_field _self st object_rest_fields in + let st = _self.ident _self st object_rest_rest in + st + +let param : 'a. ('a, param) fn = + fun _self st -> function + | Ident_param id -> _self.ident _self st id + | Object_rest_param rest -> object_rest_param _self st rest + let expression_desc : 'a. ('a, expression_desc) fn = fun _self st -> function | Length (_x0, _x1) -> @@ -165,7 +180,7 @@ let expression_desc : 'a. ('a, expression_desc) fn = let st = _self.vident _self st _x0 in st | Fun {params; body} -> - let st = list _self.ident _self st params in + let st = list param _self st params in let st = _self.block _self st body in st | Str _ -> st @@ -196,6 +211,9 @@ let expression_desc : 'a. ('a, expression_desc) fn = | Spread _x0 -> let st = _self.expression _self st _x0 in st + | Record_rest (_x0, _x1) -> + let st = _self.expression _self st _x1 in + st let for_ident_expression : 'a. ('a, for_ident_expression) fn = fun _self arg -> _self.expression _self arg diff --git a/compiler/core/js_record_iter.ml b/compiler/core/js_record_iter.ml index da86618ae3c..f925e5ab370 100644 --- a/compiler/core/js_record_iter.ml +++ b/compiler/core/js_record_iter.ml @@ -79,6 +79,19 @@ let property_map : property_map fn = let length_object : length_object fn = unknown +let record_rest_field : record_rest_field fn = + fun _self {record_rest_ident; _} -> option _self.ident _self record_rest_ident + +let object_rest_param : object_rest_param fn = + fun _self {object_rest_fields; object_rest_rest} -> + list record_rest_field _self object_rest_fields; + _self.ident _self object_rest_rest + +let param : param fn = + fun _self -> function + | Ident_param id -> _self.ident _self id + | Object_rest_param rest -> object_rest_param _self rest + let expression_desc : expression_desc fn = fun _self -> function | Length (_x0, _x1) -> @@ -127,7 +140,7 @@ let expression_desc : expression_desc fn = option (fun _self arg -> list _self.expression _self arg) _self _x1 | Var _x0 -> _self.vident _self _x0 | Fun {params; body} -> - list _self.ident _self params; + list param _self params; _self.block _self body | Str _ -> () | Raw_js_code _ -> () @@ -145,6 +158,7 @@ let expression_desc : expression_desc fn = | Null -> () | Await _x0 -> _self.expression _self _x0 | Spread _x0 -> _self.expression _self _x0 + | Record_rest (_x0, _x1) -> _self.expression _self _x1 let for_ident_expression : for_ident_expression fn = fun _self arg -> _self.expression _self arg diff --git a/compiler/core/js_record_map.ml b/compiler/core/js_record_map.ml index 26551861718..4e1d19deb62 100644 --- a/compiler/core/js_record_map.ml +++ b/compiler/core/js_record_map.ml @@ -89,6 +89,26 @@ let property_map : property_map fn = let length_object : length_object fn = unknown +let record_rest_field : record_rest_field fn = + fun _self ({record_rest_ident} as field) -> + let record_rest_ident = option _self.ident _self record_rest_ident in + {field with record_rest_ident} + +let object_rest_param : object_rest_param fn = + fun _self {object_rest_fields; object_rest_rest} -> + let object_rest_fields = list record_rest_field _self object_rest_fields in + let object_rest_rest = _self.ident _self object_rest_rest in + {object_rest_fields; object_rest_rest} + +let param : param fn = + fun _self -> function + | Ident_param id -> + let id = _self.ident _self id in + Ident_param id + | Object_rest_param rest -> + let rest = object_rest_param _self rest in + Object_rest_param rest + let expression_desc : expression_desc fn = fun _self -> function | Length (_x0, _x1) -> @@ -163,7 +183,7 @@ let expression_desc : expression_desc fn = let _x0 = _self.vident _self _x0 in Var _x0 | Fun ({params; body} as fun_) -> - let params = list _self.ident _self params in + let params = list param _self params in let body = _self.block _self body in Fun {fun_ with params; body} | Str _ as v -> v @@ -194,6 +214,9 @@ let expression_desc : expression_desc fn = | Spread _x0 -> let _x0 = _self.expression _self _x0 in Spread _x0 + | Record_rest (_x0, _x1) -> + let _x1 = _self.expression _self _x1 in + Record_rest (_x0, _x1) let for_ident_expression : for_ident_expression fn = fun _self arg -> _self.expression _self arg diff --git a/compiler/core/lam_compile_main.cppo.ml b/compiler/core/lam_compile_main.cppo.ml index cdecf32ef8e..115b2bc5248 100644 --- a/compiler/core/lam_compile_main.cppo.ml +++ b/compiler/core/lam_compile_main.cppo.ml @@ -256,6 +256,8 @@ js |> _j "external_shadow" |> Js_pass_tailcall_inline.tailcall_inline |> _j "inline_and_shake" +|> Js_pass_record_rest.program +|> _j "record_rest" |> Js_pass_flatten_and_mark_dead.program |> _j "flatten_and_mark_dead" (* |> Js_inline_and_eliminate.inline_and_shake *) diff --git a/compiler/core/lam_compile_primitive.ml b/compiler/core/lam_compile_primitive.ml index 9dfffa9fc08..13f1fe9fa5c 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -612,26 +612,12 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) | Precord_rest excluded -> ( match args with | [e1] -> - (* Generate: (({field1: __unused0, ...__rest}) => __rest)(source) - This uses JS destructuring to cleanly extract the rest while - safely handling quoted property names and the empty-exclusion case. *) - let excluded_bindings = - List.mapi - (fun i field -> - let field = Js_dump_property.property_key (Js_op.Lit field) in - Printf.sprintf "%s: __unused%d" field i) - excluded - in - let destructured = - match excluded_bindings with - | [] -> "...__rest" - | _ -> String.concat ", " excluded_bindings ^ ", ...__rest" - in - let code = Printf.sprintf "(({%s}) => __rest)" destructured in - E.call - ~info:{arity = Full; call_info = Call_na; call_transformed_jsx = false} - (E.raw_js_code (Exp (Js_function {arity = 1; arrow = true})) code) - [e1] + E.record_rest + (List.map + (fun record_rest_label -> + {J.record_rest_label; record_rest_ident = None}) + excluded) + e1 | _ -> assert false) | Phash -> ( match args with diff --git a/rewatch/tests/snapshots/rename-file.txt b/rewatch/tests/snapshots/rename-file.txt index 347bc002df3..76af6e8b3ff 100644 --- a/rewatch/tests/snapshots/rename-file.txt +++ b/rewatch/tests/snapshots/rename-file.txt @@ -25,7 +25,6 @@ Unknown field 'some-new-field' found in the package config of '@testrepo/depreca Package 'rescript-nodejs' uses deprecated config (support will be removed in a future version): - field 'bs-dependencies' — use 'dependencies' instead - field 'bs-dev-dependencies' — use 'dev-dependencies' instead - - filename 'bsconfig.json' — rename to 'rescript.json' Please report this to the package maintainer: https://github.com/TheSpyder/rescript-nodejs/issues Package 'sury' uses deprecated config (support will be removed in a future version): diff --git a/tests/build_tests/super_errors/expected/record_rest_empty_warning.res.expected b/tests/build_tests/super_errors/expected/record_rest_empty_warning.res.expected index 30d52282aef..f3343bc01d8 100644 --- a/tests/build_tests/super_errors/expected/record_rest_empty_warning.res.expected +++ b/tests/build_tests/super_errors/expected/record_rest_empty_warning.res.expected @@ -1,5 +1,5 @@ - Warning number 111 + Warning number 112 /.../fixtures/record_rest_empty_warning.res:3:16-26 1 │ type source = {a: int, b?: string} @@ -7,4 +7,4 @@ 3 │ let {a, ?b, ...sub as rest} = ({a: 1}: source) 4 │ - All fields of the rest type are already present in the explicit pattern. The rest record will always be empty. \ No newline at end of file + All fields of the rest type are already present in the explicit pattern. The rest record will always be empty. diff --git a/tests/build_tests/super_errors/expected/record_rest_private_type.res.expected b/tests/build_tests/super_errors/expected/record_rest_private_type.res.expected index 3058651a5cc..36391ac4e88 100644 --- a/tests/build_tests/super_errors/expected/record_rest_private_type.res.expected +++ b/tests/build_tests/super_errors/expected/record_rest_private_type.res.expected @@ -3,8 +3,8 @@ /.../fixtures/record_rest_private_type.res:9:12-14 7 │ type source = {a: int, b: string} - 8 │ + 8 │ 9 │ let {a, ...M.t as rest} = ({a: 1, b: "x"}: source) - 10 │ + 10 │ - Cannot create values of the private type M.t \ No newline at end of file + Cannot create values of the private type M.t diff --git a/tests/tests/src/record_rest_test.mjs b/tests/tests/src/record_rest_test.mjs index afdcfc397a7..7320eb231cc 100644 --- a/tests/tests/src/record_rest_test.mjs +++ b/tests/tests/src/record_rest_test.mjs @@ -6,79 +6,86 @@ import * as Test_utils from "./test_utils.mjs"; let SubConfig = {}; function describeConfig(c) { - let rest = ((({name: __unused0, ...__rest}) => __rest))(c); + let {name, ...rest} = c; return [ - c.name, + name, rest ]; } -function getAliasedRest(param) { - return ((({name: __unused0, ...__rest}) => __rest))(param); +function getNameAndSubConfig({name, ...subConfig}) { + return [ + name, + subConfig + ]; } -function getNamespacedRest(param) { - return ((({name: __unused0, ...__rest}) => __rest))(param); +function getAliasedRest({name: __unused0, ...rest}) { + return rest; } -function getRenamedRest(param) { - return ((({"user-name": __unused0, ...__rest}) => __rest))(param); +function getNamespacedRest({name: __unused0, ...rest}) { + return rest; +} + +function getRenamedRest({"user-name": __unused0, ...rest}) { + return rest; } function getName(param) { return param.name; } -function getWholeConfig(param) { - return ((({...__rest}) => __rest))(param); +function getWholeConfig({...rest}) { + return rest; } -function extractClassName(param) { - return ((({className: __unused0, ...__rest}) => __rest))(param); +function extractClassName({className: __unused0, ...rest}) { + return rest; } -function getValue(param) { - return ((({id: __unused0, ...__rest}) => __rest))(param); +function getValue({id: __unused0, ...rest}) { + return rest; } function getTupleRest(param) { - return ((({name: __unused0, ...__rest}) => __rest))(param[0]); + return (({name: __unused0, ...__rest}) => __rest)(param[0]); } function getWrappedRest(wrapped) { - return ((({name: __unused0, ...__rest}) => __rest))(wrapped._0); + return (({name: __unused0, ...__rest}) => __rest)(wrapped._0); } function getInlineWrappedRest(wrapped) { - return ((({TAG: __unused0, name: __unused1, ...__rest}) => __rest))(wrapped); + return (({TAG: __unused0, name: __unused1, ...__rest}) => __rest)(wrapped); } function getRenamedInlineWrappedRest(wrapped) { - return ((({TAG: __unused0, "user-name": __unused1, ...__rest}) => __rest))(wrapped); + return (({TAG: __unused0, "user-name": __unused1, ...__rest}) => __rest)(wrapped); } function getCustomTaggedInlineWrappedRest(wrapped) { - return ((({kind: __unused0, name: __unused1, ...__rest}) => __rest))(wrapped); + return (({kind: __unused0, name: __unused1, ...__rest}) => __rest)(wrapped); } function getDashedTaggedInlineWrappedRest(wrapped) { - return ((({"custom-tag": __unused0, name: __unused1, ...__rest}) => __rest))(wrapped); + return (({"custom-tag": __unused0, name: __unused1, ...__rest}) => __rest)(wrapped); } Mocha.describe("Record_rest_test", () => { Mocha.test("let binding captures record rest value", () => { - let rest = ((({name: __unused0, ...__rest}) => __rest))({ + let {name: __unused0, ...rest} = { name: "test", version: "1.0", debug: true - }); - Test_utils.eq("File \"record_rest_test.res\", line 136, characters 7-14", "test", "test"); - Test_utils.eq("File \"record_rest_test.res\", line 137, characters 7-14", rest, { + }; + Test_utils.eq("File \"record_rest_test.res\", line 138, characters 7-14", "test", "test"); + Test_utils.eq("File \"record_rest_test.res\", line 139, characters 7-14", rest, { version: "1.0", debug: true }); }); - Mocha.test("match arm returns the named field and the rest record", () => Test_utils.eq("File \"record_rest_test.res\", line 142, characters 6-13", describeConfig({ + Mocha.test("match arm returns the named field and the rest record", () => Test_utils.eq("File \"record_rest_test.res\", line 144, characters 6-13", describeConfig({ name: "match", version: "2.0", debug: false @@ -89,12 +96,12 @@ Mocha.describe("Record_rest_test", () => { debug: false } ])); - Mocha.test("function parameter destructuring keeps the named field", () => Test_utils.eq("File \"record_rest_test.res\", line 149, characters 7-14", getName({ + Mocha.test("function parameter destructuring keeps the named field", () => Test_utils.eq("File \"record_rest_test.res\", line 151, characters 7-14", getName({ name: "param", version: "3.0", debug: true }), "param")); - Mocha.test("record rest accepts type aliases to record shapes", () => Test_utils.eq("File \"record_rest_test.res\", line 154, characters 6-13", getAliasedRest({ + Mocha.test("record rest accepts type aliases to record shapes", () => Test_utils.eq("File \"record_rest_test.res\", line 156, characters 6-13", getAliasedRest({ name: "aliased", version: "3.1", debug: false @@ -103,7 +110,7 @@ Mocha.describe("Record_rest_test", () => { debug: false })); Mocha.test("record rest accepts namespaced record types", () => { - Test_utils.eq("File \"record_rest_test.res\", line 162, characters 6-13", getNamespacedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 164, characters 6-13", getNamespacedRest({ name: "namespaced", version: "3.15", debug: true @@ -111,17 +118,17 @@ Mocha.describe("Record_rest_test", () => { version: "3.15", debug: true }); - let rest = ((({name: __unused0, ...__rest}) => __rest))({ + let {name: __unused0, ...rest} = { name: "namespaced-let", version: "3.16", debug: false - }); - Test_utils.eq("File \"record_rest_test.res\", line 174, characters 7-14", rest, { + }; + Test_utils.eq("File \"record_rest_test.res\", line 176, characters 7-14", rest, { version: "3.16", debug: false }); }); - Mocha.test("record rest excludes fields renamed with @as", () => Test_utils.eq("File \"record_rest_test.res\", line 179, characters 6-13", getRenamedRest({ + Mocha.test("record rest excludes fields renamed with @as", () => Test_utils.eq("File \"record_rest_test.res\", line 181, characters 6-13", getRenamedRest({ "user-name": "renamed", version: "3.2", debug: true @@ -129,7 +136,7 @@ Mocha.describe("Record_rest_test", () => { version: "3.2", debug: true })); - Mocha.test("empty-field rest pattern still binds the whole record", () => Test_utils.eq("File \"record_rest_test.res\", line 187, characters 6-13", ((({...__rest}) => __rest))({ + Mocha.test("empty-field rest pattern still binds the whole record", () => Test_utils.eq("File \"record_rest_test.res\", line 189, characters 6-13", (({...__rest}) => __rest)({ name: "whole", version: "3.5", debug: false @@ -144,13 +151,13 @@ Mocha.describe("Record_rest_test", () => { version: "3.6", debug: true }; - let rest = ((({...__rest}) => __rest))(whole); - Test_utils.eq("File \"record_rest_test.res\", line 195, characters 7-14", whole, { + let {...rest} = whole; + Test_utils.eq("File \"record_rest_test.res\", line 197, characters 7-14", whole, { name: "wholeAlias", version: "3.6", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 196, characters 7-14", rest, { + Test_utils.eq("File \"record_rest_test.res\", line 198, characters 7-14", rest, { name: "wholeAlias", version: "3.6", debug: true @@ -163,28 +170,28 @@ Mocha.describe("Record_rest_test", () => { style: "bold", onClick: onClick }); - Test_utils.eq("File \"record_rest_test.res\", line 202, characters 7-14", rest, { + Test_utils.eq("File \"record_rest_test.res\", line 204, characters 7-14", rest, { style: "bold", onClick: onClick }); }); Mocha.test("polymorphic rest captures the value field", () => { - let intRest = ((({id: __unused0, ...__rest}) => __rest))({ + let {id: __unused0, ...intRest} = { id: "1", value: 42 - }); - Test_utils.eq("File \"record_rest_test.res\", line 207, characters 7-14", "1", "1"); - Test_utils.eq("File \"record_rest_test.res\", line 208, characters 7-14", intRest, { + }; + Test_utils.eq("File \"record_rest_test.res\", line 209, characters 7-14", "1", "1"); + Test_utils.eq("File \"record_rest_test.res\", line 210, characters 7-14", intRest, { value: 42 }); - Test_utils.eq("File \"record_rest_test.res\", line 209, characters 7-14", ((({id: __unused0, ...__rest}) => __rest))({ + Test_utils.eq("File \"record_rest_test.res\", line 211, characters 7-14", (({id: __unused0, ...__rest}) => __rest)({ id: "2", value: "hello" }), { value: "hello" }); }); - Mocha.test("tuple nested record rest is initialized", () => Test_utils.eq("File \"record_rest_test.res\", line 214, characters 6-13", getTupleRest([ + Mocha.test("tuple nested record rest is initialized", () => Test_utils.eq("File \"record_rest_test.res\", line 216, characters 6-13", getTupleRest([ { name: "tuple", version: "4.0", @@ -196,7 +203,7 @@ Mocha.describe("Record_rest_test", () => { debug: false })); Mocha.test("variant payload rest works through the or-pattern path", () => { - Test_utils.eq("File \"record_rest_test.res\", line 222, characters 6-13", getWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 224, characters 6-13", getWrappedRest({ TAG: "Wrap", _0: { name: "wrapped", @@ -207,7 +214,7 @@ Mocha.describe("Record_rest_test", () => { version: "5.0", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 227, characters 6-13", getWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 229, characters 6-13", getWrappedRest({ TAG: "Mirror", _0: { name: "mirror", @@ -220,7 +227,7 @@ Mocha.describe("Record_rest_test", () => { }); }); Mocha.test("inline record variant rest removes the runtime tag field", () => { - Test_utils.eq("File \"record_rest_test.res\", line 235, characters 6-13", getInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 237, characters 6-13", getInlineWrappedRest({ TAG: "InlineWrap", name: "inline", version: "7.0", @@ -229,7 +236,7 @@ Mocha.describe("Record_rest_test", () => { version: "7.0", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 240, characters 6-13", getInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 242, characters 6-13", getInlineWrappedRest({ TAG: "InlineMirror", name: "inlineMirror", version: "8.0", @@ -240,7 +247,7 @@ Mocha.describe("Record_rest_test", () => { }); }); Mocha.test("inline record variant rest excludes fields renamed with @as", () => { - Test_utils.eq("File \"record_rest_test.res\", line 248, characters 6-13", getRenamedInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 250, characters 6-13", getRenamedInlineWrappedRest({ TAG: "RenamedInlineWrap", "user-name": "inlineRenamed", version: "8.5", @@ -249,7 +256,7 @@ Mocha.describe("Record_rest_test", () => { version: "8.5", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 255, characters 6-13", getRenamedInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 257, characters 6-13", getRenamedInlineWrappedRest({ TAG: "RenamedInlineMirror", "user-name": "inlineRenamed2", version: "8.6", @@ -260,7 +267,7 @@ Mocha.describe("Record_rest_test", () => { }); }); Mocha.test("inline record variant rest removes a custom runtime tag field", () => { - Test_utils.eq("File \"record_rest_test.res\", line 265, characters 6-13", getCustomTaggedInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 267, characters 6-13", getCustomTaggedInlineWrappedRest({ kind: "CustomInlineWrap", name: "customInline", version: "9.0", @@ -269,7 +276,7 @@ Mocha.describe("Record_rest_test", () => { version: "9.0", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 272, characters 6-13", getCustomTaggedInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 274, characters 6-13", getCustomTaggedInlineWrappedRest({ kind: "CustomInlineMirror", name: "customInlineMirror", version: "10.0", @@ -280,7 +287,7 @@ Mocha.describe("Record_rest_test", () => { }); }); Mocha.test("inline record rest works with a non-identifier custom tag name", () => { - Test_utils.eq("File \"record_rest_test.res\", line 282, characters 6-13", getDashedTaggedInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 284, characters 6-13", getDashedTaggedInlineWrappedRest({ "custom-tag": "DashedInlineWrap", name: "dashedInline", version: "11.0", @@ -289,7 +296,7 @@ Mocha.describe("Record_rest_test", () => { version: "11.0", debug: true }); - Test_utils.eq("File \"record_rest_test.res\", line 289, characters 6-13", getDashedTaggedInlineWrappedRest({ + Test_utils.eq("File \"record_rest_test.res\", line 291, characters 6-13", getDashedTaggedInlineWrappedRest({ "custom-tag": "DashedInlineMirror", name: "dashedInlineMirror", version: "12.0", @@ -304,6 +311,7 @@ Mocha.describe("Record_rest_test", () => { export { SubConfig, describeConfig, + getNameAndSubConfig, getAliasedRest, getNamespacedRest, getRenamedRest, diff --git a/tests/tests/src/record_rest_test.res b/tests/tests/src/record_rest_test.res index 68bd07c8aa3..c58d714900b 100644 --- a/tests/tests/src/record_rest_test.res +++ b/tests/tests/src/record_rest_test.res @@ -33,6 +33,8 @@ let describeConfig = (c: config) => | {name, ...subConfig as rest} => (name, rest) } +let getNameAndSubConfig = ({name, ...subConfig as subConfig}: config) => (name, subConfig) + let getAliasedRest = ({name: _, ...aliasedSubConfig as rest}: config) => rest let getNamespacedRest = ({name: _, ...SubConfig.t as rest}: config) => rest diff --git a/tests/tools_tests/src/expected/ZRecordRest.res.jsout b/tests/tools_tests/src/expected/ZRecordRest.res.jsout index d5248cb5beb..75da4bbdf89 100644 --- a/tests/tools_tests/src/expected/ZRecordRest.res.jsout +++ b/tests/tools_tests/src/expected/ZRecordRest.res.jsout @@ -2,10 +2,9 @@ 'use strict'; -function extract(param) { - let rest = ((({name: __unused0, ...__rest}) => __rest))(param); +function extract({name, ...rest}) { return [ - param.name, + name, rest ]; }