diff --git a/analysis/reanalyze/src/DeadValue.ml b/analysis/reanalyze/src/DeadValue.ml index 0bb26e9dca1..0d1cb00f361 100644 --- a/analysis/reanalyze/src/DeadValue.ml +++ b/analysis/reanalyze/src/DeadValue.ml @@ -228,7 +228,7 @@ let collectPattern ~config ~refs : fun super self pat -> let posFrom = 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 = posTo}}, _pat, _) -> if !Config.analyzeTypes then diff --git a/analysis/src/CompletionFrontEnd.ml b/analysis/src/CompletionFrontEnd.ml index a5c0f9ce377..7cbae4dc38b 100644 --- a/analysis/src/CompletionFrontEnd.ml +++ b/analysis/src/CompletionFrontEnd.ml @@ -514,7 +514,7 @@ let completionWithParser1 ~currentFile ~debug ~offset ~path ~posCursor (NPolyvariantPayload {itemNum = 0; constructorName = txt} :: patternPath) ?contextPath 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/CompletionPatterns.ml b/analysis/src/CompletionPatterns.ml index 8755c48457f..8c03d0aa4c2 100644 --- a/analysis/src/CompletionPatterns.ml +++ b/analysis/src/CompletionPatterns.ml @@ -102,12 +102,12 @@ and traversePattern (pat : Parsetree.pattern) ~patternPath ~locHasCursor [Completable.NTupleItem {itemNum}] @ patternPath) ~resultFromFoundItemNum:(fun itemNum -> [Completable.NTupleItem {itemNum = itemNum + 1}] @ patternPath) - | Ppat_record ([], _) -> + | Ppat_record ([], _, _rest) -> (* Empty fields means we're in a record body `{}`. Complete for the fields. *) someIfHasCursor ("", [Completable.NRecordBody {seenFields = []}] @ patternPath) "Ppat_record(empty)" - | Ppat_record (fields, _) -> ( + | Ppat_record (fields, _, _rest) -> ( let fieldWithCursor = ref None in let fieldWithPatHole = ref None in Ext_list.iter fields (fun {lid = fname; x = f} -> diff --git a/analysis/src/DumpAst.ml b/analysis/src/DumpAst.ml index 39b05b3e6f0..af93b9a4178 100644 --- a/analysis/src/DumpAst.ml +++ b/analysis/src/DumpAst.ml @@ -99,7 +99,7 @@ let rec printPattern pattern ~pos ~indentation = | None -> "" | Some pat -> "," ^ printPattern pat ~pos ~indentation) ^ ")" - | Ppat_record (fields, _) -> + | Ppat_record (fields, _, _rest) -> "Ppat_record(\n" ^ addIndentation (indentation + 1) ^ "fields:\n" diff --git a/analysis/src/Hint.ml b/analysis/src/Hint.ml index 71b1b7cfe3a..9155065253f 100644 --- a/analysis/src/Hint.ml +++ b/analysis/src/Hint.ml @@ -43,7 +43,7 @@ let inlay ~path ~pos ~maxLength ~debug = let rec processPattern (pat : Parsetree.pattern) = match pat.ppat_desc with | Ppat_tuple pl -> pl |> List.iter processPattern - | Ppat_record (fields, _) -> + | Ppat_record (fields, _, _rest) -> Ext_list.iter fields (fun {x = p} -> processPattern p) | Ppat_array fields -> fields |> List.iter processPattern | Ppat_var {loc} -> push loc Type diff --git a/analysis/src/ProcessCmt.ml b/analysis/src/ProcessCmt.ml index 96601f6e3be..ca114b8189a 100644 --- a/analysis/src/ProcessCmt.ml +++ b/analysis/src/ProcessCmt.ml @@ -512,7 +512,7 @@ let rec forStructureItem ~(env : SharedTypes.Env.t) ~(exported : Exported.t) | Tpat_tuple pats | Tpat_array pats | Tpat_construct (_, _, pats) -> pats |> List.iter (fun p -> handlePattern [] p) | Tpat_or (p, _, _) -> handlePattern [] p - | Tpat_record (items, _) -> + | Tpat_record (items, _, _rest) -> items |> List.iter (fun (_, _, p, _) -> handlePattern [] p) | Tpat_variant (_, Some p, _) -> handlePattern [] p | Tpat_variant (_, None, _) | Tpat_any | Tpat_constant _ -> () diff --git a/analysis/src/ProcessExtra.ml b/analysis/src/ProcessExtra.ml index 75390cefbad..7f33779598f 100644 --- a/analysis/src/ProcessExtra.ml +++ b/analysis/src/ProcessExtra.ml @@ -391,7 +391,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) -> addForRecord ~env ~extra ~recordType:pattern.pat_type items | Tpat_construct (lident, constructor, _) -> addForConstructor ~env ~extra pattern.pat_type lident constructor diff --git a/analysis/src/SemanticTokens.ml b/analysis/src/SemanticTokens.ml index ddccba9b2b1..d005236a9f3 100644 --- a/analysis/src/SemanticTokens.ml +++ b/analysis/src/SemanticTokens.ml @@ -231,7 +231,7 @@ let command ~debug ~emitter ~path = | 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 |> emitRecordLabel ~label ~debug); Ast_iterator.default_iterator.pat iterator p diff --git a/analysis/src/SignatureHelp.ml b/analysis/src/SignatureHelp.ml index e4c9cb11ae1..d3bbecec838 100644 --- a/analysis/src/SignatureHelp.ml +++ b/analysis/src/SignatureHelp.ml @@ -664,7 +664,8 @@ let signatureHelp ~path ~pos ~currentFile ~debug ~allowForConstructorPayloads = match tupleItemWithCursor with | None -> -1 | Some i -> i) - | `ConstructorPat (_, {ppat_desc = Ppat_record (fields, _)}) -> ( + | `ConstructorPat (_, {ppat_desc = Ppat_record (fields, _, _rest)}) + -> ( let fieldNameWithCursor = fields |> List.find_map diff --git a/analysis/src/Xform.ml b/analysis/src/Xform.ml index ddf783c5590..50db786e223 100644 --- a/analysis/src/Xform.ml +++ b/analysis/src/Xform.ml @@ -76,7 +76,7 @@ module IfThenElse = struct in match listToPat ~itemToPat items with | None -> None - | Some patItems -> Some (mkPat (Ppat_record (patItems, Closed)))) + | Some patItems -> Some (mkPat (Ppat_record (patItems, 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 a4b78bea0eb..941c509d41b 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 e7c377e97a7..508902704c8 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -603,6 +603,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 2e88a3b7036..abc2f60688c 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -205,6 +205,8 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = | Pfield (id, info) -> prim ~primitive:(Pfield (id, info)) ~args loc | Psetfield (id, info) -> prim ~primitive:(Psetfield (id, info)) ~args loc | Pduprecord -> prim ~primitive:Pduprecord ~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 2135293c850..579e07fd4a0 100644 --- a/compiler/core/lam_primitive.ml +++ b/compiler/core/lam_primitive.ml @@ -40,6 +40,7 @@ type t = | Psetfield of int * Lam_compat.set_field_dbg_info (* could have field info at least for record *) | Pduprecord + | Precord_spread_new of string list (* External call *) | Pjs_call of { prim_name: string; @@ -226,9 +227,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 | Pcreate_extension a -> ( match rhs with diff --git a/compiler/core/lam_primitive.mli b/compiler/core/lam_primitive.mli index 879f03a4120..45c46bffe02 100644 --- a/compiler/core/lam_primitive.mli +++ b/compiler/core/lam_primitive.mli @@ -36,6 +36,7 @@ type t = | Pfield of int * Lambda.field_dbg_info | Psetfield of int * Lambda.set_field_dbg_info | Pduprecord + | 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 172e219abb7..76a4d2eceef 100644 --- a/compiler/core/lam_print.ml +++ b/compiler/core/lam_print.ml @@ -81,6 +81,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 292e199b5ae..3110bef2eb6 100644 --- a/compiler/frontend/bs_ast_mapper.ml +++ b/compiler/frontend/bs_ast_mapper.ml @@ -425,8 +425,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 2fae640eb07..ebe2463cc9d 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 11227b903ad..ac70088b0a8 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 a430bb0b7bd..35a92edffb7 100644 --- a/compiler/ml/ast_iterator.ml +++ b/compiler/ml/ast_iterator.ml @@ -398,7 +398,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 673465477bd..f45a476129c 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -389,8 +389,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 d0ac43d737a..5f32ba55470 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -559,7 +559,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 e5e39eb4b55..cf2bbe3a00d 100644 --- a/compiler/ml/depend.ml +++ b/compiler/ml/depend.ml @@ -183,7 +183,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 db810d4f912..cb5204915ce 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 d8eaf57be6f..5f294dd5c6f 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 b84339aed94..985868c30a2 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, _) -> IdentSet.add id r | Tpat_alias (p, id, _) -> extract_vars (IdentSet.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 ebb6903c661..f366aae8d9a 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)} -> @@ -966,7 +968,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] @@ -1169,7 +1171,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 @@ -1378,7 +1381,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) @@ -1783,7 +1786,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 @@ -1830,9 +1833,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 @@ -1991,7 +1994,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) -> @@ -2000,7 +2003,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 @@ -2133,7 +2136,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 @@ -2251,7 +2254,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 @@ -2398,12 +2401,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 78c9899f744..fe647e9c982 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 585ac64b81b..90a39d5df1f 100644 --- a/compiler/ml/pprintast.ml +++ b/compiler/ml/pprintast.ml @@ -461,7 +461,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 44d699eb388..f7cc3069248 100644 --- a/compiler/ml/printast.ml +++ b/compiler/ml/printast.ml @@ -207,7 +207,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 0282f6e113c..116b0598ca6 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 6e36b4276c0..8be8bb0516c 100644 --- a/compiler/ml/printtyped.ml +++ b/compiler/ml/printtyped.ml @@ -233,7 +233,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 3d016a74383..239c0e6ff06 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 @@ -422,7 +422,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 5c12d3da4d8..1b8b773bbef 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 54eba028699..d1e8f0deb2f 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 ee304dff7d7..aed65eac130 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -95,6 +95,12 @@ type error = | Type_params_not_supported of Longident.t | Field_access_on_dict_type | Jsx_not_enabled + | 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 @@ -496,7 +502,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 @@ -1478,7 +1484,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 @@ -1537,12 +1543,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; @@ -2066,7 +2206,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 = @@ -4788,6 +4928,32 @@ let report_error env loc ppf error = fprintf ppf "Cannot compile JSX expression because JSX support is not enabled. Add \ \"jsx\" settings to rescript.json to enable JSX support." + | 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 eef17d05a84..907a1f3e7c7 100644 --- a/compiler/ml/typecore.mli +++ b/compiler/ml/typecore.mli @@ -128,6 +128,12 @@ type error = | Type_params_not_supported of Longident.t | Field_access_on_dict_type | Jsx_not_enabled + | 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 e7274f12456..8f7c9a298d8 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 @@ -413,7 +422,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, _) -> @@ -425,8 +434,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) @@ -446,6 +456,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 b1e7083fc75..b4d81f1b71f 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/typedtreeIter.ml b/compiler/ml/typedtreeIter.ml index 9a31b9b5b96..559095836d9 100644 --- a/compiler/ml/typedtreeIter.ml +++ b/compiler/ml/typedtreeIter.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 52a57b89c55..7662305773f 100644 --- a/compiler/syntax/src/res_ast_debugger.ml +++ b/compiler/syntax/src/res_ast_debugger.ml @@ -787,7 +787,7 @@ module SexpAst = 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 6774b2bc2b1..228e183f1e1 100644 --- a/compiler/syntax/src/res_comments_table.ml +++ b/compiler/syntax/src/res_comments_table.ml @@ -2094,7 +2094,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 aab15e930fa..9dfb0dc307e 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -271,6 +271,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 @@ -1452,9 +1453,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 -> ( @@ -1495,14 +1558,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 -> @@ -1510,12 +1573,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 ErrorMessages.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 2010d23f6dd..ed95e598abf 100644 --- a/compiler/syntax/src/res_printer.ml +++ b/compiler/syntax/src/res_printer.ml @@ -2579,7 +2579,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 ParsetreeViewer.has_dict_pattern_attribute p.ppat_attributes -> Doc.concat [ @@ -2597,9 +2597,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 [ @@ -2614,9 +2628,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 +}