diff --git a/CHANGELOG.md b/CHANGELOG.md index 070c866edc8..bd6bd8940da 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -24,6 +24,7 @@ - Add a first-class `taggedTemplate<'param, 'output>` builtin type and the `TaggedTemplate` stdlib module (`TaggedTemplate.make`). Tagged-template tags are now tracked through the type system, so they emit real JS tagged-template syntax across module boundaries, when passed as first-class values, and when constructed at runtime by a factory (e.g. `postgres`). https://github.com/rescript-lang/rescript/pull/8461 - Make mutation of private record mutable fields a configurable warning instead of a hard error. https://github.com/rescript-lang/rescript/pull/8366 +- Add support for pattern matching/destructuring of record rest. https://github.com/rescript-lang/rescript/pull/8317 #### :bug: Bug fix diff --git a/analysis/reanalyze/src/dead_value.ml b/analysis/reanalyze/src/dead_value.ml index aa82de7f77d..3fd1c343b79 100644 --- a/analysis/reanalyze/src/dead_value.ml +++ b/analysis/reanalyze/src/dead_value.ml @@ -230,16 +230,78 @@ let rec collect_expr ~config ~refs ~file_deps ~cross_file With this annotation we declare a new type for each branch to allow the function to be typed. *) -let collect_pattern ~config ~refs : +let type_path_candidates ~file ~(module_path : Module_path.t) path = + let path = Dce_path.from_path_t path in + let module_context = + module_path.path @ [File_context.module_name_tagged file] + in + let add_unique paths path = + if List.exists (fun existing -> existing = path) paths then paths + else path :: paths + in + [path; path @ module_context] + |> List.fold_left + (fun paths path -> + [ + path; + Dce_path.module_to_implementation path; + Dce_path.module_to_interface path; + ] + |> List.fold_left add_unique paths) + [] + +let add_record_label_type_references ~config ~refs ~pos_from labels = + labels + |> List.iter (fun {Types.ld_loc = {loc_start = pos_to; loc_ghost}; _} -> + if not loc_ghost then + Dead_type.add_type_reference ~config ~refs ~pos_from ~pos_to) + +let add_record_rest_type_references_from_path ~config ~decls ~refs ~file + ~module_path ~pos_from rest = + if !Config.analyze_types then + match (Ctype.repr rest.Typedtree.rest_type).desc with + | Types.Tconstr (path, _, _) -> + let type_paths = type_path_candidates ~file ~module_path path in + decls |> Declarations.builder_to_list + |> List.iter (fun (_, decl) -> + match (decl.Decl.decl_kind, decl.path) with + | RecordLabel, _label :: type_path + when List.exists + (fun candidate -> candidate = type_path) + type_paths -> + Dead_type.add_type_reference ~config ~refs ~pos_from + ~pos_to:decl.pos + | _ -> ()) + | _ -> () + +let add_record_rest_type_references ~config ~decls ~refs ~file ~module_path + ~pos_from ~env rest = + if !Config.analyze_types then + match + try Some (Ctype.extract_concrete_typedecl env rest.Typedtree.rest_type) + with Not_found -> None + with + | Some (_, _, {Types.type_kind = Type_record (labels, _)}) -> + add_record_label_type_references ~config ~refs ~pos_from labels + | _ -> + add_record_rest_type_references_from_path ~config ~decls ~refs ~file + ~module_path ~pos_from rest + +let collect_pattern ~config ~decls ~refs ~file ~module_path : _ -> _ -> Typedtree.pattern -> Typedtree.pattern = 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 - Dead_type.add_type_reference ~config ~refs ~pos_from ~pos_to) + Dead_type.add_type_reference ~config ~refs ~pos_from ~pos_to); + match rest with + | None -> () + | Some rest -> + add_record_rest_type_references ~config ~decls ~refs ~file ~module_path + ~pos_from:rest.rest_name.loc.loc_start ~env:pat.pat_env rest) | _ -> ()); super.Tast_mapper.pat self pat @@ -331,7 +393,11 @@ let traverse_structure ~config ~decls ~refs ~file_deps ~cross_file ~file e |> collect_expr ~config ~refs ~file_deps ~cross_file ~last_binding super mapper); - pat = (fun _self p -> p |> collect_pattern ~config ~refs super mapper); + pat = + (fun _self p -> + p + |> collect_pattern ~config ~decls ~refs ~file ~module_path super + mapper); structure_item = (fun _self (structure_item : Typedtree.structure_item) -> let modulePath_for_item_opt = diff --git a/analysis/src/completion_front_end.ml b/analysis/src/completion_front_end.ml index aeaf7657903..31f6dc52076 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} -> @@ -526,7 +526,16 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file (Completable.NFollowRecordField {field_name = fname} :: pattern_path) ?context_path p - | _ -> ()) + | _ -> ()); + match rest with + | None -> () + | Some {rest_name = {txt; loc}; rest_type; _} -> + let context_path = + match rest_type with + | Some typ -> Type_utils.context_path_from_core_type typ + | None -> context_path_to_save + in + scope := !scope |> Scope.add_value ~name:txt ~loc ?context_path) | Ppat_array pl -> pl |> List.iter diff --git a/analysis/src/completion_patterns.ml b/analysis/src/completion_patterns.ml index cc1a270cab7..fdbd30aeaec 100644 --- a/analysis/src/completion_patterns.ml +++ b/analysis/src/completion_patterns.ml @@ -48,6 +48,13 @@ and traverse_pattern (pat : Parsetree.pattern) ~pattern_path ~loc_has_cursor Some v) else None in + let rest_cursor (rest : Parsetree.record_pat_rest option) = + match rest with + | Some {rest_name = {txt; loc}; _} when loc_has_cursor loc -> + Some (`Name txt) + | Some {rest_loc; _} when loc_has_cursor rest_loc -> Some `Rest + | _ -> None + in match pat.ppat_desc with | Ppat_constant _ | Ppat_interval _ -> None | Ppat_constraint (p, _) @@ -106,12 +113,16 @@ 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, _) -> ( + match rest_cursor rest with + | Some (`Name txt) -> Some (txt, pattern_path) + | Some `Rest -> None + | None -> + some_if_has_cursor + ("", [Completable.NRecordBody {seen_fields = []}] @ pattern_path) + "Ppat_record(empty)") + | 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} -> @@ -131,8 +142,10 @@ and traverse_pattern (pat : Parsetree.pattern) ~pattern_path ~loc_has_cursor | {Location.txt = Longident.Lident field_name} -> Some field_name | _ -> None) in - match (!field_with_cursor, !field_with_pat_hole) with - | Some (fname, f), _ | None, Some (fname, f) -> ( + match (rest_cursor rest, !field_with_cursor, !field_with_pat_hole) with + | Some (`Name txt), _, _ -> Some (txt, pattern_path) + | Some `Rest, _, _ -> None + | None, Some (fname, f), _ | None, None, Some (fname, f) -> ( match f.ppat_desc with | Ppat_extension ({txt = "rescript.patternhole"}, _) -> (* A pattern hole means for example `{someField: }`. We want to complete for the type of `someField`. *) @@ -154,7 +167,7 @@ and traverse_pattern (pat : Parsetree.pattern) ~pattern_path ~loc_has_cursor @ pattern_path) ~loc_has_cursor ~first_char_before_cursor_no_white ~pos_before_cursor) - | None, None -> ( + | None, None, None -> ( (* Figure out if we're completing for a new field. If the cursor is inside of the record body, but no field has the cursor, and there's no pattern hole. Check the first char to the left of the cursor, diff --git a/analysis/src/dump_ast.ml b/analysis/src/dump_ast.ml index 0ebb44c0d5a..19b45e07f2a 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, _) -> + | Ppat_record (fields, _, rest) -> "Ppat_record(\n" ^ add_indentation (indentation + 1) ^ "fields:\n" @@ -112,6 +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) ^ "\n" ^ add_indentation indentation ^ ")" diff --git a/analysis/src/hint.ml b/analysis/src/hint.ml index 7206a6beb8f..49b290089bc 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, _) -> - 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/process_cmt.ml b/analysis/src/process_cmt.ml index 4e6cca03bf5..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, _) -> - 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 fcd5c8e1f1d..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, _) -> - 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/analysis/src/semantic_tokens.ml b/analysis/src/semantic_tokens.ml index 92b3afe8369..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, _) -> + | 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/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..de47287bddd 100644 --- a/compiler/common/pattern_printer.ml +++ b/compiler/common/pattern_printer.ml @@ -5,6 +5,11 @@ open Asttypes let mkpat desc = Ast_helper.Pat.mk desc +let untype_record_rest (rest : Typedtree.record_pat_rest) : + Parsetree.record_pat_rest = + let rest_name = rest.rest_name in + {Parsetree.rest_loc = rest_name.loc; rest_name; rest_type = None} + let[@warning "-4"] is_generated_optional_constructor (lid : Longident.t Location.loc) = match lid.txt with @@ -76,7 +81,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 +102,8 @@ 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, Option.map untype_record_rest rest)) | Tpat_array lst -> mkpat (Ppat_array (List.map loop lst)) in loop typed diff --git a/compiler/core/j.ml b/compiler/core/j.ml index f20b22ec727..ce91d290078 100644 --- a/compiler/core/j.ml +++ b/compiler/core/j.ml @@ -77,6 +77,11 @@ 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 expression_desc = | Length of expression * length_object | Is_null_or_undefined of expression (** where we use a trick [== null ] *) @@ -165,6 +170,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 +333,7 @@ and deps_program = { finish_ident_expression; property_map; length_object; + record_rest_field; (* for_ident; *) required_modules; case_clause; @@ -337,3 +344,6 @@ 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 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..a4973352c52 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,38 @@ 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 formal_parameter_list cxt f l = iter_lst cxt f l Ext_pp_scope.ident comma_sp (* IdentMap *) (* @@ -269,6 +301,17 @@ let is_var (b : J.expression) a = | Var (Id i) -> Ident.same i a | _ -> false +let params_match_call params args fn = + 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 + type fn_exp_state = | Is_return (* for sure no name *) | Name_top of Ident.t @@ -309,16 +352,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 @@ -494,6 +528,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 +1347,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..188206119aa 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 = 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..b1857534852 100644 --- a/compiler/core/js_fold.ml +++ b/compiler/core/js_fold.ml @@ -190,6 +190,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..ef5232bfa07 --- /dev/null +++ b/compiler/core/js_pass_record_rest.ml @@ -0,0 +1,124 @@ +module E = Js_exp_make +module S = Js_stmt_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 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_desc = + Return + ({expression_desc = Record_rest (fields, source); _} as rest_expr); + _; + } as statement) + :: tail -> + let rest = Ext_ident.create "rest" in + let source = self.expression self source in + let tail = self.block self tail in + let fields, return = + materialize_fields source fields + [{statement with statement_desc = Return (E.var rest)}] + in + S.define_variable ~kind:Strict rest + {rest_expr with expression_desc = Record_rest (fields, source)} + :: (return @ tail) + | statement :: tail -> self.statement self statement :: self.block self tail + | [] -> [] + in + {super with block} + +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..f2bdc4e3506 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 = @@ -148,12 +150,11 @@ let record_scope_pass = it ignores some locally defined idents *) let param_set = Set_ident.of_list params in let {defined_idents = defined_idents'; used_idents = used_idents'} = + let mutable_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' = @@ -189,25 +190,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 +223,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_record_fold.ml b/compiler/core/js_record_fold.ml index d3e0de74358..6c7f934569a 100644 --- a/compiler/core/js_record_fold.ml +++ b/compiler/core/js_record_fold.ml @@ -196,6 +196,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..9c7be79e077 100644 --- a/compiler/core/js_record_iter.ml +++ b/compiler/core/js_record_iter.ml @@ -145,6 +145,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..65b4b524103 100644 --- a/compiler/core/js_record_map.ml +++ b/compiler/core/js_record_map.ml @@ -194,6 +194,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_analysis.ml b/compiler/core/lam_analysis.ml index 29a8d3a1602..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 + | Pduprecord | Precord_rest _ (* generic primitives *) | Pobjcomp _ | Pobjorder | Pobjmin | Pobjmax | Pobjtag | Pobjsize (* bool primitives *) 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 e6a7a86a6e3..13f1fe9fa5c 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -609,6 +609,16 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) match args with | [e1] -> E.obj ~dup:e1 [] | _ -> assert false) + | Precord_rest excluded -> ( + match args with + | [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 | [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..95ae9d94ae5 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -208,6 +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_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 974aff095b0..18467698ad6 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_rest of string list (* External call *) | Pjs_call of { prim_name: string; @@ -230,7 +231,7 @@ let eq_primitive_approx (lhs : t) (rhs : t) = | 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 -> + | Phash_mixstring | Phash_mixint | Phash_finalmix | Precord_rest _ -> 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..561c9e31255 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_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 9408b11aea4..446c28e28db 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_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/ext/warnings.ml b/compiler/ext/warnings.ml index c768ae4537c..c41ef0f8e7b 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_optional_overlap of string list (* 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_optional_overlap _ -> 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,22 @@ let message = function `%s->ignore`" help_text help_text | _ -> "") + | Bs_record_rest_optional_overlap fields -> ( + let field_list = + fields |> List.map (fun field -> "\n- " ^ field) |> String.concat "" + in + (match fields with + | [_] -> + "The following optional field appears in both the explicit pattern and \ + the rest type:" + | _ -> + "The following optional fields appear in both the explicit pattern and \ + the rest type:") + ^ field_list + ^ + match fields with + | [_] -> "\n\nIt will always be absent from the rest record." + | _ -> "\n\nThey will always be absent from the rest record.") | Bs_todo maybe_text -> (match maybe_text with | None -> "Todo found." @@ -569,6 +587,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..9514ea21e6d 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_optional_overlap of string list (* 112 *) val parse_options : bool -> string -> unit diff --git a/compiler/frontend/ast_tuple_pattern_flatten.ml b/compiler/frontend/ast_tuple_pattern_flatten.ml index 27fe1e73a85..165dede4478 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, _), Pexp_pack {pmod_desc = Pmod_ident id} -> + | Ppat_record (_, _, Some rest), Pexp_pack {pmod_desc = Pmod_ident _} -> + 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} -> 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..332ac5b57a2 100644 --- a/compiler/frontend/bs_ast_mapper.ml +++ b/compiler/frontend/bs_ast_mapper.ml @@ -433,8 +433,18 @@ 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 {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.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..ed16a6f9d12 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: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 474fec12d68..f1421d518e7 100644 --- a/compiler/ml/ast_iterator.ml +++ b/compiler/ml/ast_iterator.ml @@ -407,12 +407,17 @@ 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; sub.pat sub pat) - lpl + lpl; + 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 7953771b4c8..8e06c7729eb 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -397,8 +397,18 @@ 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 {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 c4e8f80bb35..539833fb495 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -93,6 +93,32 @@ let for_await_of_attr_name = "_res.for_await_of" let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} +(* Internal Parsetree0 bridge metadata; public res.* attributes pass through. *) +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; _}, payload) :: attrs + when attr_name = record_rest_attr_name -> ( + match payload with + | Pt.PPat (rest, None) -> ( + match record_rest_of_pattern rest with + | Some rest -> (Some rest, List.rev_append acc attrs) + | None -> failwith "Malformed internal _res.record_rest attribute") + | _ -> failwith "Malformed internal _res.record_rest attribute") + | 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 +682,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 = 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 c204651070e..3bd7bd0ad70 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -87,6 +87,20 @@ let for_await_of_attr_name = "_res.for_await_of" let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} +(* Internal Parsetree0 bridge metadata; public res.* attributes pass through. *) +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 *) @@ -601,7 +615,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) -> + | Ppat_record (lpl, cf, rest) -> + let attrs = + match rest with + | None -> attrs + | Some rest_pat -> + 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} -> let lid1 = map_loc sub lid in diff --git a/compiler/ml/depend.ml b/compiler/ml/depend.ml index 3a13d4ac003..8a3680bb183 100644 --- a/compiler/ml/depend.ml +++ b/compiler/ml/depend.ml @@ -179,12 +179,13 @@ 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; add_pattern bv p) - pl + pl; + 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 e078a2a28f8..ea759e2a506 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_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 99f399aa0ac..43b42c58498 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_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 916646ea08a..eccb49475a0 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,13 +536,21 @@ 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 +let bind_record_rest loc arg rest action = + Llet + ( Strict, + Pgenval, + rest.rest_ident, + Lprim (Precord_rest rest.excluded_runtime_labels, [arg], loc), + action ) + let simplify_cases args cls = match args with | [] -> assert false @@ -556,10 +564,23 @@ 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) -> + 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 = {pat with pat_desc = Tpat_record (all_lbls, closed)} in + let full_pat = + {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 _ -> ( let pat_simple = simplify_or pat in @@ -615,8 +636,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, _) -> - 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 -> 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 @@ -1422,7 +1446,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 +1454,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 +2585,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 +2660,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 +2670,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 diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index 4ae23724fb4..039061936de 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 @@ -1965,6 +1968,19 @@ module Conv = struct name_counter := !name_counter + 1; "#$" ^ name ^ string_of_int current + let conv_record_rest (rest : Typedtree.record_pat_rest) = + match (Btype.repr rest.rest_type).desc with + | Tconstr (path, args, _) -> + let loc = rest.rest_name.loc in + let rest_type = + Ast_helper.Typ.constr ~loc + (mkloc (Ctype.lid_of_path path) loc) + (List.map (fun _ -> Ast_helper.Typ.any ~loc ()) args) + in + Some + {rest_loc = loc; rest_name = rest.rest_name; rest_type = Some rest_type} + | _ -> None + let conv typed = let constrs = Hashtbl.create 7 in let labels = Hashtbl.create 7 in @@ -1992,7 +2008,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 +2017,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, Option.bind rest conv_record_rest)) | Tpat_array lst -> mkpat (Ppat_array (List.map loop lst)) in let ps = loop typed in @@ -2153,7 +2169,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 +2300,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 +2448,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..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,9 +190,12 @@ 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 * 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 10025b0e0e7..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) -> ( + | 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 5aae8263738..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) -> + | 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 e30f3c867f2..bb5c8832d34 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_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/printtyped.ml b/compiler/ml/printtyped.ml index f8bfaa170f2..2cf3c19c9b8 100644 --- a/compiler/ml/printtyped.ml +++ b/compiler/ml/printtyped.ml @@ -123,6 +123,10 @@ let arg_label i ppf = function | Optional {txt} -> line i ppf "Optional \"%s\"\n" txt | Labelled {txt} -> line i ppf "Labelled \"%s\"\n" txt +let record_pat_rest i ppf {rest_ident; rest_type; _} = + line i ppf "rest \"%a\" : %a\n" fmt_ident rest_ident Printtyp.type_expr + rest_type + let record_representation i ppf = let open Types in function @@ -231,9 +235,10 @@ 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 + list i longident_x_pattern ppf l; + Option.iter (record_pat_rest i ppf) rest | Tpat_array l -> line i ppf "Tpat_array\n"; list i pattern ppf l diff --git a/compiler/ml/rec_check.ml b/compiler/ml/rec_check.ml index 61f55114e97..c78457b6e14 100644 --- a/compiler/ml/rec_check.ml +++ b/compiler/ml/rec_check.ml @@ -156,8 +156,13 @@ 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, _) -> - List.concat (List.map (fun (_, _, p, _) -> pattern_variables p) fields) + | Tpat_record (fields, _, rest) -> ( + let fields = + List.concat (List.map (fun (_, _, p, _) -> pattern_variables p) fields) + in + match rest with + | None -> fields + | Some {rest_ident; _} -> rest_ident :: fields) | Tpat_array pats -> List.concat (List.map pattern_variables pats) | Tpat_or (l, r, _) -> pattern_variables l @ pattern_variables r @@ -438,7 +443,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..8bb9c672ddc 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -96,6 +96,7 @@ type error = | Field_access_on_dict_type | Jsx_not_enabled | Tagged_template_non_tag of type_expr + | Record_rest of Typecore_record_rest.error exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -512,8 +513,10 @@ let rec build_as_type env p = row_fixed = false; row_closed = false; }) - | Tpat_record (lpl, _) -> - 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 @@ -1494,7 +1497,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 +1553,35 @@ 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; + let typed_rest = + match rest with + | None -> None + | Some rest -> ( + let check_not_private loc ty decl = + if decl.type_private = Private then + raise (Error (loc, !env, Private_type ty)) + in + 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 { - 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 +2147,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 = @@ -5074,6 +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 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 cba37060eb6..c82b7d2f944 100644 --- a/compiler/ml/typecore.mli +++ b/compiler/ml/typecore.mli @@ -129,6 +129,7 @@ type error = | Field_access_on_dict_type | Jsx_not_enabled | Tagged_template_non_tag of type_expr + | 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..b6b9ad92d47 --- /dev/null +++ b/compiler/ml/typecore_record_rest.ml @@ -0,0 +1,315 @@ +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; + } + | Unboxed_record + | Mutable_source_record + +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 source_fields_and_repr ~env ~loc decl = + match decl.type_kind with + | Type_record (_, Record_unboxed _) -> raise_error loc env Unboxed_record + | Type_record (fields, repr) -> + if + Ext_list.exists fields (fun (field : label_declaration) -> + field.ld_mutable = Mutable) + then raise_error loc env Mutable_source_record; + (source_fields_of_decl fields, repr) + | _ -> assert false + +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 -> source_fields_and_repr ~env ~loc source_decl + | None -> + unify_pat_types rest_type_lid.loc env record_ty rest_type_expr; + source_fields_and_repr ~env ~loc:rest_type_lid.loc rest_decl + +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 = + Ast_untagged_variants.process_tag_name attrs + |> Option.value ~default:"TAG" + in + if List.mem tag_name explicit_runtime_labels then explicit_runtime_labels + else tag_name :: explicit_runtime_labels + | _ -> explicit_runtime_labels + +(* Type a record-rest pattern by resolving its annotation, checking that the + rest record can be formed from the source record, and returning the typed + rest binding plus the runtime labels to remove from the generated object. *) +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, rest_labels = + 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 (_, Record_unboxed _) -> + raise_error rest_type_lid.loc env Unboxed_record + | Type_record (labels, _) -> (rest_decl, labels) + | _ -> 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_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 overlapping_fields = + List.filter + (fun rest_field -> List.mem rest_field explicit_fields) + rest_field_names + in + let non_optional_overlapping_fields = + List.filter + (fun rest_field -> not (List.mem rest_field explicit_optional_fields)) + overlapping_fields + in + if non_optional_overlapping_fields <> [] then + raise_error rest.rest_loc env + (Field_not_optional (non_optional_overlapping_fields, rest_type_lid.txt)) + else if overlapping_fields <> [] then + Location.prerr_warning rest.rest_loc + (Warnings.Bs_record_rest_optional_overlap overlapping_fields); + let missing = + List.filter_map + (fun field -> + if + (not (List.mem field.source_name explicit_fields)) + && not (List.mem field.source_name rest_field_names) + then Some field.source_name + else None) + source_fields + 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; + 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 + | [_] -> + fprintf ppf + "The following field appears in both the explicit pattern and the rest \ + type `%a`:%s\n\n\ + This is not type-safe because the field would always be absent from \ + the rest value. Remove it from the rest type, or match it as optional \ + if absence is intended." + Printtyp.longident lid field_list + | _ -> + fprintf ppf + "The following fields appear in both the explicit pattern and the rest \ + type `%a`:%s\n\n\ + This is not type-safe because these fields would always be absent \ + from the rest value. Remove them from the rest type, or match them as \ + optional if absence is intended." + 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 + | Unboxed_record -> + fprintf ppf "Record rest patterns cannot be used with unboxed record types." + | Mutable_source_record -> + fprintf ppf + "Record rest patterns cannot be used on records with mutable fields." diff --git a/compiler/ml/typecore_record_rest.mli b/compiler/ml/typecore_record_rest.mli new file mode 100644 index 00000000000..f8ddf7f46a8 --- /dev/null +++ b/compiler/ml/typecore_record_rest.mli @@ -0,0 +1,35 @@ +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; + } + | Unboxed_record + | Mutable_source_record + +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 f772a0eb64b..7af0d7d7ec9 100644 --- a/compiler/ml/typedtree.ml +++ b/compiler/ml/typedtree.ml @@ -35,6 +35,13 @@ type pattern = { pat_attributes: attribute list; } +and record_pat_rest = { + rest_ident: Ident.t; + rest_name: string loc; + rest_type: type_expr; + excluded_runtime_labels: string list; +} + and pat_extra = | Tpat_constraint of core_type | Tpat_type of Path.t * Longident.t loc @@ -52,6 +59,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 +425,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 +437,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 +459,12 @@ let rec bound_idents pat = | Tpat_or (p1, _, _) -> (* Invariant : both arguments binds the same variables *) bound_idents p1 + | Tpat_record (_, _, Some rest) -> + (* Record rest is stored on Tpat_record, not as a child Tpat_var that + iter_pattern_desc can visit. Add it here so Lambda compilation sees the + binding. *) + idents := (rest.rest_ident, rest.rest_name) :: !idents; + iter_pattern_desc bound_idents pat.pat_desc | d -> iter_pattern_desc bound_idents d let pat_bound_idents pat = @@ -487,6 +502,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/ml/typedtree.mli b/compiler/ml/typedtree.mli index 538405a7691..61c4e6863c7 100644 --- a/compiler/ml/typedtree.mli +++ b/compiler/ml/typedtree.mli @@ -43,6 +43,13 @@ type pattern = { pat_attributes: attributes; } +and record_pat_rest = { + rest_ident: Ident.t; + rest_name: string loc; + rest_type: type_expr; + excluded_runtime_labels: string list; +} + and pat_extra = | Tpat_constraint of core_type (** P : T { pat_desc = P @@ -85,10 +92,11 @@ 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) - 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/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..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) -> + | 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_comments_table.ml b/compiler/syntax/src/res_comments_table.ml index 9741d3ece62..1d0a470e52a 100644 --- a/compiler/syntax/src/res_comments_table.ml +++ b/compiler/syntax/src/res_comments_table.ml @@ -498,6 +498,7 @@ type node = | ObjectField of Parsetree.object_field | PackageConstraint of Longident.t Asttypes.loc * Parsetree.core_type | Pattern of Parsetree.pattern + | PatternRecordRest of Parsetree.record_pat_rest | PatternRecordRow of Longident.t Asttypes.loc * Parsetree.pattern | RowField of Parsetree.row_field | SignatureItem of Parsetree.signature_item @@ -536,6 +537,7 @@ let get_loc node = | _ -> Location.none) | PackageConstraint (li, te) -> {li.loc with loc_end = te.ptyp_loc.loc_end} | Pattern p -> p.ppat_loc + | PatternRecordRest rest -> rest.rest_loc | PatternRecordRow (li, p) -> {li.loc with loc_end = p.ppat_loc.loc_end} | RowField rf -> ( match rf with @@ -719,6 +721,7 @@ and walk_node node tbl comments = | ObjectField f -> walk_object_field f tbl comments | PackageConstraint (li, te) -> walk_package_constraint (li, te) tbl comments | Pattern p -> walk_pattern p tbl comments + | PatternRecordRest rest -> walk_pattern_record_rest rest tbl comments | PatternRecordRow (li, p) -> walk_pattern_record_row (li, p) tbl comments | RowField rf -> walk_row_field rf tbl comments | SignatureItem si -> walk_signature_item si tbl comments @@ -2135,10 +2138,16 @@ 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, _) -> - walk_list - (Ext_list.map record_rows (fun {lid; x = p} -> PatternRecordRow (lid, p))) - t comments + | Ppat_record (record_rows, _, rest) -> + let nodes = + Ext_list.map record_rows (fun {lid; x = p} -> PatternRecordRow (lid, p)) + in + let nodes = + match rest with + | None -> nodes + | Some rest -> nodes @ [PatternRecordRest rest] + in + walk_list nodes t comments | Ppat_or _ -> walk_list (Res_parsetree_viewer.collect_or_pattern_chain pat @@ -2176,7 +2185,26 @@ and walk_pattern pat t comments = | Ppat_extension extension -> walk_extension extension t comments | _ -> () -(* name: firstName *) +and walk_pattern_record_rest rest t comments = + let attach_rest_name comments = + let before_name, after_name = + partition_leading_trailing comments rest.rest_name.loc + in + attach t.leading rest.rest_name.loc before_name; + attach t.trailing rest.rest_name.loc after_name + in + match rest.rest_type with + | None -> attach_rest_name comments + | Some typ -> + let before_typ, inside_typ, after_typ = + partition_by_loc comments typ.ptyp_loc + in + attach t.leading typ.ptyp_loc before_typ; + walk_core_type typ t inside_typ; + let after_typ, rest = partition_adjacent_trailing typ.ptyp_loc after_typ in + attach t.trailing typ.ptyp_loc after_typ; + attach_rest_name rest + and walk_pattern_record_row row t comments = match row with (* punned {x}*) diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index 2d3eabd3944..3e67dcbf26f 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -126,11 +126,14 @@ 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 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] @@ -336,6 +339,7 @@ type fundef_parameter = type record_pattern_item = | PatUnderscore | PatField of Parsetree.pattern Parsetree.record_element + | PatRest of Parsetree.record_pat_rest type context = OrdinaryExpr | TernaryTrueBranchExpr | WhenExpr @@ -1517,9 +1521,55 @@ 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 -> ( + let rest_start_pos = p.Parser.start_pos in Parser.next p; - Some (true, PatField (parse_record_pattern_row_field ~attrs p)) + let start_pos = rest_start_pos in + let rest_name_start_pos = p.Parser.start_pos 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 = + 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 + 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 + Some + ( false, + PatRest + { + Parsetree.rest_loc = loc; + rest_name = + Location.mkloc ident + (mk_loc rest_name_start_pos p.prev_end_pos); + rest_type = None; + } ) + | _ -> + (* 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 +1610,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 +1625,19 @@ 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 -> ( + match rest with + | None -> (fields, flag, Some rest_pat) + | Some _ -> + 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)) + ([], 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..dd15d0bb630 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,26 @@ 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 = + let doc = + match rest_pat.Parsetree.rest_type with + | Some typ -> + Doc.concat + [ + Doc.text "..."; + print_typ_expr ~state typ cmt_tbl; + Doc.text " as "; + print_string_loc rest_pat.rest_name cmt_tbl; + ] + | None -> + Doc.concat + [Doc.text "..."; print_string_loc rest_pat.rest_name cmt_tbl] + in + print_comments doc cmt_tbl rest_pat.rest_loc + in Doc.group (Doc.concat [ @@ -2820,9 +2837,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/ERROR_VARIANTS.md b/tests/ERROR_VARIANTS.md index 5a4b068e55b..afeba3034e4 100644 --- a/tests/ERROR_VARIANTS.md +++ b/tests/ERROR_VARIANTS.md @@ -241,6 +241,7 @@ Source: [typecore.ml:27](../compiler/ml/typecore.ml). | `Empty_record_literal` | ✓ | `empty_record_literal.res` | | | `Uncurried_arity_mismatch` | ✓ | `arity_mismatch3.res` etc. | | | `Field_not_optional` | ✓ | `fieldNotOptional.res` | | +| `Record_rest` | ✓ | `record_rest_*.res` | Wrapper for record-rest validation errors reported by `typecore_record_rest.ml`; fixtures cover missing annotation, invalid rest type, non-record and unresolved rest types, private and unboxed record types, mutable source records, field mismatch/missing/extra cases, runtime-name mismatch, non-optional overlap errors, optional overlap warnings, module destructure rejection, and singular/plural missing messages. | | `Type_params_not_supported` | ✓ | `variant_spread_pattern_type_params.res` | Pattern-level variant spread (`| ...a as v`) where `a` has type params; typedecl path covered by `variant_spread_type_parameters.res`. | | `Field_access_on_dict_type` | ✓ | `field_access_on_dict_type.res` | | | `Jsx_not_enabled` | ☐ (needs harness flag) | — | typecore.ml:218/3470. Fires when JSX is used without `-bs-jsx N`. The `super_errors` runner hard-codes `-bs-jsx 4` in `bscFlags`; adding a per-fixture opt-out (e.g. a `.opts` sidecar) would expose this. Until then, it's reachable in real code but blocked at the harness level. | @@ -327,7 +328,7 @@ Type-expression errors. Source: [typetexp.ml:28](../compiler/ml/typetexp.ml). | `Unbound_type_variable` | ✓ | (covered indirectly via many fixtures) | | | `Unbound_type_constructor` | ✓ | `typetexp_unbound_type_constructor.res` | | | `Unbound_type_constructor_2` | ✓ | `incomplete_type_constructor_polyvariant.res`, `incomplete_type_constructor_object.res` | Identity alias `type t<'a> = 'a` used in an inherit position with a type-variable arg; `expand_head` collapses `t<'b>` to a bare `Tvar` while the repr stays `Tconstr`. Reachable from poly-variant inherit and object spread. | -| `Type_arity_mismatch` | ✓ | `type_arity_mismatch.res` | | +| `Type_arity_mismatch` | ✓ | `type_arity_mismatch.res`, `record_rest_type_arity_mismatch.res` | | | `Type_mismatch` | ✓ | `typetexp_type_mismatch.res` | Type-constructor application that violates a `constraint 'a = …` on the declaration. | | `Alias_type_mismatch` | ✓ | `typetexp_alias_type_mismatch.res` | | | `Present_has_conjunction` | ✓ | `polyvariant_present_has_conjunction.res` | `[< #A(int) & (string) > #A]` — `<` syntax marks `#A` as a "present" tag, and the body has both `(int)` and `& (string)` types, so the conjunctive payload triggers the check at line 451. | diff --git a/tests/analysis_tests/tests-reanalyze/deadcode/expected/deadcode.txt b/tests/analysis_tests/tests-reanalyze/deadcode/expected/deadcode.txt index 43d47ac7eb3..10c70d7cd19 100644 --- a/tests/analysis_tests/tests-reanalyze/deadcode/expected/deadcode.txt +++ b/tests/analysis_tests/tests-reanalyze/deadcode/expected/deadcode.txt @@ -1193,6 +1193,15 @@ DeadOptionalArgs.addReferences formatDate called with optional argNames: argNamesMaybe: OptionalArgsLiveDead.res:5:23 addValueReference OptionalArgsLiveDead.res:5:4 --> OptionalArgsLiveDead.res:1:4 addValueReference OptionalArgsLiveDead.res:7:8 --> OptionalArgsLiveDead.res:5:4 + Scanning RecordRest.cmt Source:RecordRest.res + addValueDeclaration +getRest RecordRest.res:8:4 path:+RecordRest + addRecordLabelDeclaration name RecordRest.res:1:15 path:+RecordRest.config + addRecordLabelDeclaration version RecordRest.res:1:29 path:+RecordRest.config + addRecordLabelDeclaration version RecordRest.res:4:12 path:+RecordRest.SubConfig.t + addValueReference RecordRest.res:8:4 --> RecordRest.res:10:14 + addTypeReference RecordRest.res:10:4 --> RecordRest.res:1:15 + addTypeReference RecordRest.res:10:32 --> RecordRest.res:4:12 + addValueReference RecordRest.res:8:4 --> RecordRest.res:8:15 Scanning Records.cmt Source:Records.res addValueDeclaration +origin Records.res:11:4 path:+Records addValueDeclaration +computeArea Records.res:14:4 path:+Records @@ -1949,9 +1958,9 @@ Forward Liveness Analysis - decls: 698 - roots(external targets): 135 - decl-deps: decls_with_out=410 edges_to_decls=287 + decls: 702 + roots(external targets): 137 + decl-deps: decls_with_out=411 edges_to_decls=289 Root (external ref): Value +FirstClassModules.M.InnerModule2.+k Root (external ref): VariantCase DeadRT.moduleAccessPath.Root @@ -2008,6 +2017,7 @@ Forward Liveness Analysis Root (annotated): Value +ImportHooks.+foo Root (annotated): RecordLabel +ImportIndex.props.method Root (annotated): Value +Docstrings.+unnamed2U + Root (external ref): RecordLabel +RecordRest.config.name Root (external ref): Value +FirstClassModules.M.Z.+u Root (annotated): Value +Uncurried.+callback2U Root (annotated): Value +ImportJsValue.+default @@ -2132,6 +2142,7 @@ Forward Liveness Analysis Root (annotated): Value +Records.+someBusiness Root (external ref): RecordLabel +Hooks.vehicle.name Root (annotated): Value +Uncurried.+sumLblCurried + Root (annotated): Value +RecordRest.+getRest Root (annotated): Value +References.+preserveRefIdentity Root (annotated): Value +Types.+jsStringT Root (annotated): Value +Variants.+restResult1 @@ -2146,6 +2157,7 @@ Forward Liveness Analysis Root (annotated): Value +ImportJsValue.+useColor Root (annotated): Value +Tuples.+changeSecondAge Root (external ref): Value +Unison.+group + Root (external ref): RecordLabel +RecordRest.SubConfig.t.version Root (annotated): Value +Docstrings.+unnamed1U Root (annotated): Value +Records.+recordValue Root (annotated): Value +ImportHookDefault.+make @@ -2276,7 +2288,7 @@ Forward Liveness Analysis Root (annotated): Value +UseImportJsValue.+useGetProp Root (annotated): Value +Hooks.+functionWithRenamedArgs - 322 roots found + 325 roots found Propagate: DeadRT.moduleAccessPath.Root -> +DeadRT.moduleAccessPath.Root Propagate: +TypeReexportCrossFileB.reexportedRecord.usedField -> +TypeReexportCrossFileA.originalRecord.usedField @@ -3413,6 +3425,17 @@ Forward Liveness Analysis Live (external ref) Value +OptionalArgsLiveDead.+liveCaller deps: in=0 (live=0 dead=0) out=1 -> +OptionalArgsLiveDead.+formatDate + Live (external ref) RecordLabel +RecordRest.config.name + deps: in=1 (live=1 dead=0) out=0 + <- +RecordRest.+getRest (live) + Dead RecordLabel +RecordRest.config.version + Live (external ref) RecordLabel +RecordRest.SubConfig.t.version + deps: in=1 (live=1 dead=0) out=0 + <- +RecordRest.+getRest (live) + Live (annotated) Value +RecordRest.+getRest + deps: in=0 (live=0 dead=0) out=2 + -> +RecordRest.config.name + -> +RecordRest.SubConfig.t.version Live (external ref) RecordLabel +Records.coord.x deps: in=1 (live=1 dead=0) out=0 <- +Records.+computeArea (live) @@ -4902,6 +4925,10 @@ Forward Liveness Analysis OptionalArgsLiveDead.res:3:1-59 deadCaller is never used + Warning Dead Type + RecordRest.res:1:30-44 + config.version is a record label never used to read a value + Warning Dead Type Records.res:24:3-14 person.name is a record label never used to read a value @@ -5246,4 +5273,4 @@ Forward Liveness Analysis OptArg.res:26:1-70 optional argument c of function wrapfourArgs is always supplied (2 calls) - Analysis reported 318 issues (Incorrect Dead Annotation:1, Warning Dead Exception:2, Warning Dead Module:22, Warning Dead Type:93, Warning Dead Value:177, Warning Dead Value With Side Effects:5, Warning Redundant Optional Argument:6, Warning Unused Argument:12) + Analysis reported 319 issues (Incorrect Dead Annotation:1, Warning Dead Exception:2, Warning Dead Module:22, Warning Dead Type:94, Warning Dead Value:177, Warning Dead Value With Side Effects:5, Warning Redundant Optional Argument:6, Warning Unused Argument:12) diff --git a/tests/analysis_tests/tests-reanalyze/deadcode/src/RecordRest.res b/tests/analysis_tests/tests-reanalyze/deadcode/src/RecordRest.res new file mode 100644 index 00000000000..b1b76dab9fe --- /dev/null +++ b/tests/analysis_tests/tests-reanalyze/deadcode/src/RecordRest.res @@ -0,0 +1,11 @@ +type config = {name: string, version: string} + +module SubConfig = { + type t = {version: string} +} + +@live +let getRest = (config: config) => + switch config { + | {name: _, ...SubConfig.t as rest} => rest + } diff --git a/tests/analysis_tests/tests/src/RecordRest.res b/tests/analysis_tests/tests/src/RecordRest.res new file mode 100644 index 00000000000..e96f0102082 --- /dev/null +++ b/tests/analysis_tests/tests/src/RecordRest.res @@ -0,0 +1,26 @@ +type config = {name: string, version: string} +module SubConfig = { + type t = {version: string} +} + +let getVersion = (config: config) => + switch config { + | {name: _, ...SubConfig.t as rest} => + rest.version +// ^def + } + +let getVersionFromParam = ({name: _, ...SubConfig.t as paramRest}: config) => { + // param + // ^com + paramRest.version +} + +let {name: _, ...SubConfig.t as localRest} = {name: "v", version: "1"} +// ^ast + +let {...SubConfig.t as wholeRest} = {version: "2"} +// ^com + +//^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 new file mode 100644 index 00000000000..1742f63294a --- /dev/null +++ b/tests/analysis_tests/tests/src/expected/RecordRest.res.txt @@ -0,0 +1,148 @@ +Definition src/RecordRest.res 8:4 +{ + "range": { + "end": { "character": 36, "line": 7 }, + "start": { "character": 32, "line": 7 } + }, + "uri": "file:///RecordRest.res" +} + +Complete src/RecordRest.res 13:10 +posCursor:[13:10] posNoWhite:[13:9] Found expr:[12:26->16:1] +posCursor:[13:10] posNoWhite:[13:9] Found expr:[12:78->16:1] +posCursor:[13:10] posNoWhite:[13:9] Found expr:[13:5->13:10] +Pexp_ident param:[13:5->13:10] +Completable: Cpath Value[param] +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath Value[param] +Path param +[ + { + "detail": "SubConfig.t", + "documentation": { + "kind": "markdown", + "value": "```rescript\ntype t = {version: string}\n```" + }, + "kind": 12, + "label": "paramRest", + "tags": [] + } +] + +Dump AST src/RecordRest.res 18:19 + +Source: +// let {name: _, ...SubConfig.t as localRest} = {name: "v", version: "1"} +// ^ast + +<*>Pstr_value( + value: + <*>Ppat_record( + fields: + name: Ppat_any + rest: + localRest as <*>Ptyp_constr(<*>SubConfig.t) + ) + expr: + Pexp_record( + fields: + name: Pexp_constant(Pconst_string(v)) + version: Pexp_constant(Pconst_string(1)) + ) +) + +Complete src/RecordRest.res 21:9 +posCursor:[21:9] posNoWhite:[21:8] Found pattern:[21:4->21:33] +posCursor:[21:9] posNoWhite:[21:8] Found type:[21:8->21:19] +Ptyp_constr SubConfig.t:[21:8->21:19] +Completable: Cpath Type[SubConfig, t] +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath Type[SubConfig, t] +Path SubConfig.t +[ + { + "detail": "type t", + "documentation": { + "kind": "markdown", + "value": "```rescript\ntype t = {version: string}\n```" + }, + "kind": 22, + "label": "t", + "tags": [] + } +] + +Inlay Hint src/RecordRest.res 1:34 +[ + { + "kind": 1, + "label": ": SubConfig.t", + "paddingLeft": true, + "paddingRight": false, + "position": { "character": 32, "line": 21 } + }, + { + "kind": 1, + "label": ": SubConfig.t", + "paddingLeft": true, + "paddingRight": false, + "position": { "character": 41, "line": 18 } + }, + { + "kind": 1, + "label": ": config => string", + "paddingLeft": true, + "paddingRight": false, + "position": { "character": 23, "line": 12 } + }, + { + "kind": 1, + "label": ": config => string", + "paddingLeft": true, + "paddingRight": false, + "position": { "character": 14, "line": 5 } + } +] + +Highlight src/RecordRest.res +structure items:6 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 +Variable: getVersionFromParam [12:4->12:23] +Lident: name 12:28 Property +Variable: paramRest [12:55->12:64] +Ldot: SubConfig 12:40 Namespace +Lident: t 12:50 Type +Lident: config 12:67 Type +Lident: version 15:12 Property +Lident: paramRest 15:2 Variable +Lident: name 18:5 Property +Variable: localRest [18:32->18:41] +Ldot: SubConfig 18:17 Namespace +Lident: t 18:27 Type +Lident: name 18:46 Property +Lident: version 18:57 Property +Variable: wholeRest [21:23->21:32] +Ldot: SubConfig 21:8 Namespace +Lident: t 21:18 Type +Lident: version 21:37 Property + 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..4f391cb2986 --- /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:9-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_missing_singular.res.expected b/tests/build_tests/super_errors/expected/record_rest_field_missing_singular.res.expected new file mode 100644 index 00000000000..082e2df2473 --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_rest_field_missing_singular.res.expected @@ -0,0 +1,13 @@ + + We've found a bug for you! + /.../fixtures/record_rest_field_missing_singular.res:3:9-22 + + 1 │ type source = {a: int, b: string, c: bool} + 2 │ type sub = {b: string} + 3 │ let {a, ...sub as rest} = ({a: 1, b: "x", c: true}: source) + 4 │ + + The following field is not part of the rest type `sub`: +- c + +List this field in the record pattern before the spread so it's 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..73870f3e36b --- /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:9-22 + + 1 │ type source = {a: int, b: string} + 2 │ type sub = {a: int, b: string} + 3 │ let {a, ...sub as rest}: source = {a: 1, b: "x"} + 4 │ + + The following field appears in both the explicit pattern and the rest type `sub`: +- a + +This is not type-safe because the field would always be absent from the rest value. Remove it from the rest type, or match it as optional if absence is intended. diff --git a/tests/build_tests/super_errors/expected/record_rest_field_not_optional_plural.res.expected b/tests/build_tests/super_errors/expected/record_rest_field_not_optional_plural.res.expected new file mode 100644 index 00000000000..53cebe701af --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_rest_field_not_optional_plural.res.expected @@ -0,0 +1,14 @@ + + We've found a bug for you! + /.../fixtures/record_rest_field_not_optional_plural.res:3:12-25 + + 1 │ type source = {a: int, b: string} + 2 │ type sub = {a: int, b: string} + 3 │ let {a, b, ...sub as rest}: source = {a: 1, b: "x"} + 4 │ + + The following fields appear in both the explicit pattern and the rest type `sub`: +- a +- b + +This is not type-safe because these fields would always be absent from the rest value. Remove them from the rest type, or match them as optional if absence is intended. 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/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/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..93bebb2ed6e --- /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:9-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_module_destructure.res.expected b/tests/build_tests/super_errors/expected/record_rest_module_destructure.res.expected new file mode 100644 index 00000000000..edb0b39f75e --- /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:12-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/expected/record_rest_mutable_source.res.expected b/tests/build_tests/super_errors/expected/record_rest_mutable_source.res.expected new file mode 100644 index 00000000000..72cddfaa600 --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_rest_mutable_source.res.expected @@ -0,0 +1,10 @@ + + We've found a bug for you! + /.../fixtures/record_rest_mutable_source.res:4:5-30 + + 2 │ type rest = {version: string} + 3 │ + 4 │ let {name: _, ...rest as rest} = ({name: "x", version: "1"}: source) + 5 │ + + Record rest patterns cannot be used on records with mutable fields. \ 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_optional_overlap_warning.res.expected b/tests/build_tests/super_errors/expected/record_rest_optional_overlap_warning.res.expected new file mode 100644 index 00000000000..83f8bc80450 --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_rest_optional_overlap_warning.res.expected @@ -0,0 +1,13 @@ + + Warning number 112 + /.../fixtures/record_rest_optional_overlap_warning.res:3:24-37 + + 1 │ type source = {a?: int, b: string} + 2 │ type sub = {a?: int, b: string} + 3 │ let getRest = ({a: ?_, ...sub as rest}: source) => rest + 4 │ + + The following optional field appears in both the explicit pattern and the rest type: +- a + +It will always be absent from the rest record. 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..36391ac4e88 --- /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 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..77a9b9447bc --- /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:9-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/expected/record_rest_type_arity_mismatch.res.expected b/tests/build_tests/super_errors/expected/record_rest_type_arity_mismatch.res.expected new file mode 100644 index 00000000000..578d7b874e3 --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_rest_type_arity_mismatch.res.expected @@ -0,0 +1,11 @@ + + We've found a bug for you! + /.../fixtures/record_rest_type_arity_mismatch.res:3:16-19 + + 1 │ type source<'a> = {id: string, value: 'a} + 2 │ type rest<'a> = {value: 'a} + 3 │ let {id: _, ...rest as value} = ({id: "x", value: 1}: sourc + │ e) + 4 │ + + The type constructor `rest` expects 1 type argument, but is given 2 \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/record_rest_unboxed_rest_type.res.expected b/tests/build_tests/super_errors/expected/record_rest_unboxed_rest_type.res.expected new file mode 100644 index 00000000000..b756afccc83 --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_rest_unboxed_rest_type.res.expected @@ -0,0 +1,10 @@ + + We've found a bug for you! + /.../fixtures/record_rest_unboxed_rest_type.res:4:18-22 + + 2 │ @unboxed type value = {value: int} + 3 │ + 4 │ let {name: _, ...value as rest} = ({name: "x", value: 1}: source) + 5 │ + + Record rest patterns cannot be used with unboxed record types. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/record_rest_unboxed_source_type.res.expected b/tests/build_tests/super_errors/expected/record_rest_unboxed_source_type.res.expected new file mode 100644 index 00000000000..4aedcdec32f --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_rest_unboxed_source_type.res.expected @@ -0,0 +1,10 @@ + + We've found a bug for you! + /.../fixtures/record_rest_unboxed_source_type.res:4:5-32 + + 2 │ type empty = {} + 3 │ + 4 │ let {value: _, ...empty as rest} = ({value: 1}: source) + 5 │ + + Record rest patterns cannot be used with unboxed record types. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/record_rest_unresolved_rest_type.res.expected b/tests/build_tests/super_errors/expected/record_rest_unresolved_rest_type.res.expected new file mode 100644 index 00000000000..eeaa9882dc2 --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_rest_unresolved_rest_type.res.expected @@ -0,0 +1,10 @@ + + We've found a bug for you! + /.../fixtures/record_rest_unresolved_rest_type.res:3:12-15 + + 1 │ type source = {a: int, b: string} + 2 │ type rest + 3 │ let {a, ...rest as value} = ({a: 1, b: "x"}: source) + 4 │ + + Type rest 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/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_missing_singular.res b/tests/build_tests/super_errors/fixtures/record_rest_field_missing_singular.res new file mode 100644 index 00000000000..da285704e4c --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/record_rest_field_missing_singular.res @@ -0,0 +1,3 @@ +type source = {a: int, b: string, c: bool} +type sub = {b: string} +let {a, ...sub as rest} = ({a: 1, b: "x", c: true}: 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..e5a6f70b7d5 --- /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} +type sub = {a: int, b: string} +let {a, ...sub as rest}: source = {a: 1, b: "x"} diff --git a/tests/build_tests/super_errors/fixtures/record_rest_field_not_optional_plural.res b/tests/build_tests/super_errors/fixtures/record_rest_field_not_optional_plural.res new file mode 100644 index 00000000000..4ce606b7a67 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/record_rest_field_not_optional_plural.res @@ -0,0 +1,3 @@ +type source = {a: int, b: string} +type sub = {a: int, b: string} +let {a, b, ...sub as rest}: source = {a: 1, b: "x"} 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/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/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_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) diff --git a/tests/build_tests/super_errors/fixtures/record_rest_mutable_source.res b/tests/build_tests/super_errors/fixtures/record_rest_mutable_source.res new file mode 100644 index 00000000000..a204a98c33b --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/record_rest_mutable_source.res @@ -0,0 +1,4 @@ +type source = {mutable name: string, version: string} +type rest = {version: string} + +let {name: _, ...rest as rest} = ({name: "x", version: "1"}: 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_optional_overlap_warning.res b/tests/build_tests/super_errors/fixtures/record_rest_optional_overlap_warning.res new file mode 100644 index 00000000000..39166e604ed --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/record_rest_optional_overlap_warning.res @@ -0,0 +1,3 @@ +type source = {a?: int, b: string} +type sub = {a?: int, b: string} +let getRest = ({a: ?_, ...sub as rest}: source) => rest 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) 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) diff --git a/tests/build_tests/super_errors/fixtures/record_rest_type_arity_mismatch.res b/tests/build_tests/super_errors/fixtures/record_rest_type_arity_mismatch.res new file mode 100644 index 00000000000..52667f6265d --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/record_rest_type_arity_mismatch.res @@ -0,0 +1,3 @@ +type source<'a> = {id: string, value: 'a} +type rest<'a> = {value: 'a} +let {id: _, ...rest as value} = ({id: "x", value: 1}: source) diff --git a/tests/build_tests/super_errors/fixtures/record_rest_unboxed_rest_type.res b/tests/build_tests/super_errors/fixtures/record_rest_unboxed_rest_type.res new file mode 100644 index 00000000000..b5692385fa8 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/record_rest_unboxed_rest_type.res @@ -0,0 +1,4 @@ +type source = {name: string, value: int} +@unboxed type value = {value: int} + +let {name: _, ...value as rest} = ({name: "x", value: 1}: source) diff --git a/tests/build_tests/super_errors/fixtures/record_rest_unboxed_source_type.res b/tests/build_tests/super_errors/fixtures/record_rest_unboxed_source_type.res new file mode 100644 index 00000000000..1ece901fa16 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/record_rest_unboxed_source_type.res @@ -0,0 +1,4 @@ +@unboxed type source = {value: int} +type empty = {} + +let {value: _, ...empty as rest} = ({value: 1}: source) diff --git a/tests/build_tests/super_errors/fixtures/record_rest_unresolved_rest_type.res b/tests/build_tests/super_errors/fixtures/record_rest_unresolved_rest_type.res new file mode 100644 index 00000000000..d6617a043e3 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/record_rest_unresolved_rest_type.res @@ -0,0 +1,3 @@ +type source = {a: int, b: string} +type rest +let {a, ...rest as value} = ({a: 1, b: "x"}: source) diff --git a/tests/ounit_tests/ounit_ast_mapper0_tests.ml b/tests/ounit_tests/ounit_ast_mapper0_tests.ml new file mode 100644 index 00000000000..b1d902e34d0 --- /dev/null +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -0,0 +1,79 @@ +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) +let assert_failure = OUnit.assert_failure + +let loc = Location.none + +let attr name payload = ({Location.txt = name; loc}, payload) + +let has_attr name attrs = + List.exists (fun ({Location.txt}, _) -> txt = name) attrs + +let record_pat0 attrs = + Ast_helper0.Pat.record ~loc ~attrs + [ + ( Location.mknoloc (Longident.Lident "name"), + Ast_helper0.Pat.var ~loc (Location.mknoloc "name") ); + ] + Asttypes.Open + +let map_pat0 pat = + Ast_mapper_from0.default_mapper.pat Ast_mapper_from0.default_mapper pat + +let test_public_record_rest_attr_is_not_internal _ = + let pat = + map_pat0 (record_pat0 [attr "res.record_rest" (Parsetree0.PStr [])]) + in + match pat.ppat_desc with + | Parsetree.Ppat_record (_, _, None) -> + OUnit.assert_bool "public res.record_rest attribute was not preserved" + (has_attr "res.record_rest" pat.ppat_attributes) + | Parsetree.Ppat_record (_, _, Some _) -> + assert_failure "public res.record_rest attribute was decoded as record rest" + | _ -> assert_failure "Expected a record pattern" + +let test_malformed_internal_record_rest_attr_fails _ = + OUnit.assert_raises (Failure "Malformed internal _res.record_rest attribute") + (fun () -> + ignore + (map_pat0 (record_pat0 [attr "_res.record_rest" (Parsetree0.PStr [])]))) + +let test_record_rest_roundtrips_through_ast0 _ = + let rest = + Some + { + Parsetree.rest_loc = loc; + rest_name = Location.mknoloc "rest"; + rest_type = None; + } + in + let pat = + Ast_helper.Pat.record ~loc ?rest + [ + { + Parsetree.lid = Location.mknoloc (Longident.Lident "name"); + x = Ast_helper.Pat.var ~loc (Location.mknoloc "name"); + opt = false; + }; + ] + Asttypes.Open + in + let pat0 = + Ast_mapper_to0.default_mapper.pat Ast_mapper_to0.default_mapper pat + in + let pat = map_pat0 pat0 in + match pat.ppat_desc with + | Parsetree.Ppat_record + (_, _, Some {rest_name = {txt = "rest"; _}; rest_type = None; _}) -> + () + | _ -> assert_failure "Expected record rest after ast0 roundtrip" + +let suites = + __FILE__ + >::: [ + "public_record_rest_attr_is_not_internal" + >:: test_public_record_rest_attr_is_not_internal; + "malformed_internal_record_rest_attr_fails" + >:: test_malformed_internal_record_rest_attr_fails; + "record_rest_roundtrips_through_ast0" + >:: test_record_rest_roundtrips_through_ast0; + ] diff --git a/tests/ounit_tests/ounit_js_analyzer_tests.ml b/tests/ounit_tests/ounit_js_analyzer_tests.ml index 6a595cfd1a0..eab675470ab 100644 --- a/tests/ounit_tests/ounit_js_analyzer_tests.ml +++ b/tests/ounit_tests/ounit_js_analyzer_tests.ml @@ -3,6 +3,16 @@ let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) let pure_iterable = Js_exp_make.var (Ident.create "iterable") let empty_body = [] +let record_rest_expression source field = + Js_exp_make.record_rest + [{J.record_rest_label = "name"; record_rest_ident = Some field}] + (Js_exp_make.var source) + +let record_rest_expression_without_idents source = + Js_exp_make.record_rest + [{J.record_rest_label = "name"; record_rest_ident = None}] + (Js_exp_make.var source) + let for_of_statement = { J.statement_desc = @@ -17,6 +27,48 @@ let for_await_of_statement = comment = None; } +let record_rest_statement ~source ~field ~rest = + Js_stmt_make.define_variable ~kind:Lam_compat.Strict rest + (record_rest_expression source field) + +let function_expression param body = + { + J.expression_desc = + Fun + { + is_method = false; + params = [param]; + body; + env = Js_fun_env.make 1; + return_unit = false; + async = false; + directive = None; + }; + comment = None; + } + +let transform_expression expression = + let fn = Ident.create "fn" in + let program = + Js_pass_record_rest.program + { + J.block = + [Js_stmt_make.define_variable ~kind:Lam_compat.Strict fn expression]; + exports = []; + export_set = Set_ident.empty; + } + in + match program.block with + | [ + { + statement_desc = + Variable {value = Some ({expression_desc = Fun _; _} as expression); _}; + _; + }; + ] -> + expression + | _ -> OUnit.assert_failure __LOC__ + let suites = __FILE__ >::: [ @@ -27,4 +79,132 @@ let suites = OUnit.assert_bool __LOC__ (not (Js_analyzer.no_side_effect_statement for_await_of_statement)) ); + ( __LOC__ >:: fun _ -> + let source = Ident.create "source" in + let field = Ident.create "name" in + OUnit.assert_bool __LOC__ + (not + (Js_analyzer.no_side_effect_expression + (record_rest_expression source field))) ); + ( __LOC__ >:: fun _ -> + let source = Ident.create "source" in + let field = Ident.create "name" in + OUnit.assert_bool __LOC__ + (not + (Js_analyzer.eq_expression + (record_rest_expression source field) + (record_rest_expression source field))) ); + ( __LOC__ >:: fun _ -> + let source = Ident.create "source" in + let field = Ident.create "name" in + let rest = Ident.create "rest" in + let free = + Js_analyzer.free_variables_of_statement + (record_rest_statement ~source ~field ~rest) + in + OUnit.assert_bool __LOC__ (Set_ident.mem free source); + OUnit.assert_bool __LOC__ (not (Set_ident.mem free field)); + OUnit.assert_bool __LOC__ (not (Set_ident.mem free rest)) ); + ( __LOC__ >:: fun _ -> + let param = Ident.create "param" in + let transformed = + transform_expression + (function_expression param + [ + Js_stmt_make.return_stmt + (record_rest_expression_without_idents param); + ]) + in + match transformed.expression_desc with + | Fun + { + params = [transformed_param]; + body = + [ + { + statement_desc = + Variable + { + ident = rest; + value = + Some + { + expression_desc = + Record_rest + ( [ + { + record_rest_label = "name"; + record_rest_ident = Some ignored; + }; + ], + {expression_desc = Var (Id source); _} + ); + _; + }; + _; + }; + _; + }; + { + statement_desc = + Return {expression_desc = Var (Id returned); _}; + _; + }; + ]; + _; + } -> + OUnit.assert_bool __LOC__ (Ident.same param transformed_param); + OUnit.assert_equal "__unused0" (Ident.name ignored); + OUnit.assert_equal "rest" (Ident.name rest); + OUnit.assert_bool __LOC__ (Ident.same param source); + OUnit.assert_bool __LOC__ (Ident.same rest returned) + | _ -> OUnit.assert_failure __LOC__ ); + ( __LOC__ >:: fun _ -> + let rest = Ident.create "rest" in + let program = + Js_pass_record_rest.program + { + J.block = + [ + Js_stmt_make.define_variable ~kind:Lam_compat.Strict rest + (Js_exp_make.record_rest + [ + { + record_rest_label = "name"; + record_rest_ident = None; + }; + ] + {expression_desc = Object (None, []); comment = None}); + ]; + exports = []; + export_set = Set_ident.empty; + } + in + match program.block with + | [ + { + statement_desc = + Variable + { + value = + Some + { + expression_desc = + Record_rest + ( [ + { + record_rest_label = "name"; + record_rest_ident = Some ignored; + }; + ], + _ ); + _; + }; + _; + }; + _; + }; + ] -> + OUnit.assert_equal "__unused0" (Ident.name ignored) + | _ -> OUnit.assert_failure __LOC__ ); ] diff --git a/tests/ounit_tests/ounit_pattern_printer_tests.ml b/tests/ounit_tests/ounit_pattern_printer_tests.ml new file mode 100644 index 00000000000..daa1ef026f3 --- /dev/null +++ b/tests/ounit_tests/ounit_pattern_printer_tests.ml @@ -0,0 +1,115 @@ +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) + +let loc = Location.none + +let rest_type = + Btype.newgenty + (Types.Tconstr (Path.Pident (Ident.create "restConfig"), [], ref Types.Mnil)) + +let record_type = + Btype.newgenty + (Types.Tconstr (Path.Pident (Ident.create "config"), [], ref Types.Mnil)) + +let record_rest_pattern = + let rest = Ident.create "_rest" in + { + Typedtree.pat_desc = + Tpat_record + ( [], + Asttypes.Closed, + Some + { + rest_ident = rest; + rest_name = Location.mknoloc (Ident.name rest); + rest_type; + excluded_runtime_labels = []; + } ); + pat_loc = loc; + pat_extra = []; + pat_type = rest_type; + pat_env = Env.empty; + pat_attributes = []; + } + +let int_pattern n = + { + record_rest_pattern with + Typedtree.pat_desc = Tpat_constant (Const_int n); + pat_type = Predef.type_int; + } + +let count_label = + let label = + { + Types.lbl_name = "count"; + lbl_res = record_type; + lbl_arg = Predef.type_int; + lbl_mut = Asttypes.Immutable; + lbl_optional = false; + lbl_pos = 0; + lbl_all = [||]; + lbl_repres = Record_regular; + lbl_private = Asttypes.Public; + lbl_loc = loc; + lbl_attributes = []; + } + in + label.lbl_all <- [|label|]; + label + +let record_with_rest_pattern = + { + record_rest_pattern with + Typedtree.pat_desc = + Tpat_record + ( [ + ( Location.mknoloc (Longident.Lident "count"), + count_label, + int_pattern 1, + false ); + ], + Asttypes.Closed, + match record_rest_pattern.pat_desc with + | Tpat_record (_, _, rest) -> rest + | _ -> assert false ); + pat_type = record_type; + } + +let dummy_expr = + { + Typedtree.exp_desc = Texp_constant (Const_int 0); + exp_loc = loc; + exp_extra = []; + exp_type = Predef.type_int; + exp_env = Env.empty; + exp_attributes = []; + } + +let assert_parmatch_conv_keeps_record_rest _ = + let converted_pattern = ref None in + let pred _ _ pattern = + converted_pattern := Some pattern; + None + in + ignore + (Parmatch.check_partial_gadt pred loc + [{c_lhs = record_with_rest_pattern; c_guard = None; c_rhs = dummy_expr}]); + match !converted_pattern with + | Some {Parsetree.ppat_desc = Ppat_record (_, _, Some rest)} -> + OUnit.assert_equal ~printer:(fun x -> x) "_rest" rest.rest_name.txt; + OUnit.assert_bool __LOC__ (Option.is_some rest.rest_type) + | Some pattern -> + OUnit.assert_failure + (Format.asprintf "Expected record rest, got %a" Pprintast.pattern pattern) + | None -> OUnit.assert_failure "Expected exhaustiveness predicate to run" + +let suites = + __FILE__ + >::: [ + ( __LOC__ >:: fun _ -> + OUnit.assert_equal + ~printer:(fun x -> x) + "{..._rest}" + (Pattern_printer.print_pattern record_rest_pattern) ); + __LOC__ >:: assert_parmatch_conv_keeps_record_rest; + ] diff --git a/tests/ounit_tests/ounit_rec_check_tests.ml b/tests/ounit_tests/ounit_rec_check_tests.ml new file mode 100644 index 00000000000..ef2fbfa88e1 --- /dev/null +++ b/tests/ounit_tests/ounit_rec_check_tests.ml @@ -0,0 +1,61 @@ +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) + +let loc = Location.none +let typ = Predef.type_unit + +let val_desc = + {Types.val_type = typ; val_kind = Val_reg; val_loc = loc; val_attributes = []} + +let ident_expr id = + { + Typedtree.exp_desc = + Texp_ident + ( Path.Pident id, + Location.mknoloc (Longident.Lident (Ident.name id)), + val_desc ); + exp_loc = loc; + exp_extra = []; + exp_type = typ; + exp_env = Env.empty; + exp_attributes = []; + } + +let record_rest_pat rest_ident = + { + Typedtree.pat_desc = + Tpat_record + ( [], + Asttypes.Closed, + Some + { + rest_ident; + rest_name = Location.mknoloc (Ident.name rest_ident); + rest_type = typ; + excluded_runtime_labels = []; + } ); + pat_loc = loc; + pat_extra = []; + pat_type = typ; + pat_env = Env.empty; + pat_attributes = []; + } + +let value_binding ~pat ~expr = + {Typedtree.vb_pat = pat; vb_expr = expr; vb_attributes = []; vb_loc = loc} + +let suites = + __FILE__ + >::: [ + ( __LOC__ >:: fun _ -> + let rest = Ident.create "rest" in + let binding = + value_binding ~pat:(record_rest_pat rest) ~expr:(ident_expr rest) + in + let raised = + try + Rec_check.check_recursive_bindings [binding]; + false + with _ -> true + in + OUnit.assert_bool __LOC__ raised ); + ] diff --git a/tests/ounit_tests/ounit_tests_main.ml b/tests/ounit_tests/ounit_tests_main.ml index aefc3f3abe2..b0241a6aa3b 100644 --- a/tests/ounit_tests/ounit_tests_main.ml +++ b/tests/ounit_tests/ounit_tests_main.ml @@ -18,6 +18,9 @@ let suites = Ounit_utf8_test.suites; Ounit_unicode_tests.suites; Ounit_util_tests.suites; + Ounit_rec_check_tests.suites; + Ounit_ast_mapper0_tests.suites; + Ounit_pattern_printer_tests.suites; Ounit_js_analyzer_tests.suites; Ounit_jsx_loc_tests.suites; Ounit_analysis_config_tests.suites; 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..57e70a605ef --- /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:6-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 { ...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 2b33d97dbce..feb12d9ad5d 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,41 +22,55 @@ 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:4:15-18 + syntax_tests/data/parsing/errors/other/spread.res:4:6-18 2 │ 3 │ let record = {...x, ...y} 4 │ let {...x, ...y} = myRecord - 5 │ - 6 │ let list{...x, ...y} = myList + 5 │ let {...M.t} = myRecord + 6 │ - 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. + 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: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. let [|arr;_|] = [|1;2;3|] let record = { x with y } -let { x; y } = myRecord +let { ...y } = myRecord +let { M.t = t } = myRecord let x::y = myList type nonrec t = { ...: a } 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/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 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..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 @@ -80,4 +80,19 @@ 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; ...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/grammar/pattern/record.res b/tests/syntax_tests/data/parsing/grammar/pattern/record.res index 424baffc8e6..9dc155b1343 100644 --- a/tests/syntax_tests/data/parsing/grammar/pattern/record.res +++ b/tests/syntax_tests/data/parsing/grammar/pattern/record.res @@ -88,3 +88,25 @@ 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}) => () + +// 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/parsing/recovery/pattern/expected/parenthesized.res.txt b/tests/syntax_tests/data/parsing/recovery/pattern/expected/parenthesized.res.txt index ca5a43ff607..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; b } -> () + | { 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 68b19a38259..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,18 +9,7 @@ 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; ...x } -> () + | { a; b } -> () \ No newline at end of file diff --git a/tests/syntax_tests/data/printer/comments/expected/pattern.res.txt b/tests/syntax_tests/data/printer/comments/expected/pattern.res.txt index 5463de9be0d..275b2f251ef 100644 --- a/tests/syntax_tests/data/printer/comments/expected/pattern.res.txt +++ b/tests/syntax_tests/data/printer/comments/expected/pattern.res.txt @@ -58,6 +58,11 @@ let /* before */ { /* c3 */ age /* c4 */: /* c5 */ ageInYears /* c6 */, } /* after */ = {name: "steve", age: 31} +let /* before */ { + /* c0 */ name /* c1 */, + /* before rest */ .../* before type */ SubConfig.t /* after type */ as /* before name */ rest /* after rest */, +} /* after */ = config + // Ppat_or let /* b1 */ Blue /* b2 */ | /* c1 */ Red /* c2 */ = color let /* b1 */ Blue /* b2 */ | /* c1 */ Red /* c2 */ | /* d1 */ Green /* d2 */ = color diff --git a/tests/syntax_tests/data/printer/comments/pattern.res b/tests/syntax_tests/data/printer/comments/pattern.res index 8bcb620b8f0..996ef9bdb8e 100644 --- a/tests/syntax_tests/data/printer/comments/pattern.res +++ b/tests/syntax_tests/data/printer/comments/pattern.res @@ -54,6 +54,11 @@ let /* before */ { /* c3 */ age /* c4 */: /* c5 */ ageInYears /* c6 */, } /* after */ = {name: "steve", age: 31} +let /* before */ { + /* c0 */ name /* c1 */, + /* before rest */ .../* before type */ SubConfig.t /* after type */ as /* before name */ rest /* after rest */, +} /* after */ = config + // Ppat_or let /* b1 */ Blue /* b2 */ | /* c1 */ Red /* c2 */ = color let /* b1 */ Blue /* b2 */ | /* c1 */ Red /* c2 */ | /* d1 */ Green /* d2 */ = color 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 new file mode 100644 index 00000000000..4b2e393e7dc --- /dev/null +++ b/tests/tests/src/record_rest_test.mjs @@ -0,0 +1,422 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + +import * as Mocha from "mocha"; +import * as Test_utils from "./test_utils.mjs"; + +let RestConfig = {}; + +function describeConfig(c) { + let {name, ...rest} = c; + return [ + name, + rest + ]; +} + +function getNameAndRestConfig(param) { + let {name, ...restConfig} = param; + return [ + name, + restConfig + ]; +} + +function getAliasedRest(param) { + let {name: __unused0, ...rest} = param; + return rest; +} + +function getNamespacedRest(param) { + let {name: __unused0, ...rest} = param; + return rest; +} + +function getRenamedRest(param) { + let {"user-name": __unused0, ...rest} = param; + return rest; +} + +function getRenamedNameAndRest(param) { + let {"user-name": __rest_field0, ...rest} = param; + return [ + __rest_field0, + rest + ]; +} + +function getName(param) { + return param.name; +} + +function getWholeConfig(param) { + let {...rest} = param; + return rest; +} + +function makeConfig() { + return { + name: "call", + version: "4.5", + debug: true + }; +} + +function getCallResultRest() { + let {name: __unused0, ...rest} = { + name: "call", + version: "4.5", + debug: true + }; + return rest; +} + +function getNameRestAndOriginalVersion(original) { + let {name, ...rest} = original; + return [ + name, + rest, + original.version + ]; +} + +function extractClassName(param) { + let {className: __unused0, ...rest} = param; + return rest; +} + +function getValue(param) { + let {id: __unused0, ...rest} = param; + return rest; +} + +function getTupleRest(param) { + let {name: __unused0, ...rest} = param[0]; + return rest; +} + +function getWrappedRest(wrapped) { + let {name: __unused0, ...rest} = wrapped._0; + return rest; +} + +function getInlineWrappedRest(wrapped) { + let {TAG: __unused0, name: __unused1, ...rest} = wrapped; + return rest; +} + +function getRenamedInlineWrappedRest(wrapped) { + let {TAG: __unused0, "user-name": __unused1, ...rest} = wrapped; + return rest; +} + +function getCustomTaggedInlineWrappedRest(wrapped) { + let {kind: __unused0, name: __unused1, ...rest} = wrapped; + return rest; +} + +function getDashedTaggedInlineWrappedRest(wrapped) { + let {"custom-tag": __unused0, name: __unused1, ...rest} = wrapped; + return rest; +} + +Mocha.describe("Record_rest_test", () => { + Mocha.test("let binding captures record rest value", () => { + let {name: __unused0, ...rest} = { + name: "test", + version: "1.0", + debug: true + }; + Test_utils.eq("File \"record_rest_test.res\", line 151, characters 7-14", "test", "test"); + Test_utils.eq("File \"record_rest_test.res\", line 152, 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 157, 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 164, 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 169, characters 6-13", getAliasedRest({ + name: "aliased", + version: "3.1", + debug: false + }), { + version: "3.1", + debug: false + })); + Mocha.test("record rest accepts namespaced record types", () => { + Test_utils.eq("File \"record_rest_test.res\", line 177, characters 6-13", getNamespacedRest({ + name: "namespaced", + version: "3.15", + debug: true + }), { + version: "3.15", + debug: true + }); + let {name: __unused0, ...rest} = { + name: "namespaced-let", + version: "3.16", + debug: false + }; + Test_utils.eq("File \"record_rest_test.res\", line 189, 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 194, characters 6-13", getRenamedRest({ + "user-name": "renamed", + version: "3.2", + debug: true + }), { + version: "3.2", + debug: true + })); + Mocha.test("record rest can return a field renamed with @as alongside the rest", () => Test_utils.eq("File \"record_rest_test.res\", line 202, characters 6-13", getRenamedNameAndRest({ + "user-name": "renamed", + version: "3.25", + debug: false + }), [ + "renamed", + { + version: "3.25", + debug: false + } + ])); + Mocha.test("empty-field rest pattern still binds the whole record", () => Test_utils.eq("File \"record_rest_test.res\", line 210, characters 6-13", (({...__rest}) => __rest)({ + name: "whole", + version: "3.5", + debug: false + }), { + name: "whole", + 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} = whole; + Test_utils.eq("File \"record_rest_test.res\", line 218, characters 7-14", whole, { + name: "wholeAlias", + version: "3.6", + debug: true + }); + Test_utils.eq("File \"record_rest_test.res\", line 219, 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({ + className: "btn", + style: "bold", + onClick: onClick + }); + Test_utils.eq("File \"record_rest_test.res\", line 225, characters 7-14", rest, { + style: "bold", + onClick: onClick + }); + }); + Mocha.test("polymorphic rest captures the value field", () => { + let {id: __unused0, ...intRest} = { + id: "1", + value: 42 + }; + Test_utils.eq("File \"record_rest_test.res\", line 230, characters 7-14", "1", "1"); + Test_utils.eq("File \"record_rest_test.res\", line 231, characters 7-14", intRest, { + value: 42 + }); + Test_utils.eq("File \"record_rest_test.res\", line 232, 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 237, characters 6-13", getTupleRest([ + { + name: "tuple", + version: "4.0", + debug: false + }, + 1 + ]), { + version: "4.0", + debug: false + })); + Mocha.test("record rest works when the source is not a bare identifier", () => Test_utils.eq("File \"record_rest_test.res\", line 244, characters 7-14", getCallResultRest(), { + version: "4.5", + debug: true + })); + Mocha.test("record rest keeps the original parameter alias usable", () => Test_utils.eq("File \"record_rest_test.res\", line 249, characters 6-13", getNameRestAndOriginalVersion({ + name: "original", + version: "4.75", + debug: false + }), [ + "original", + { + version: "4.75", + debug: false + }, + "4.75" + ])); + Mocha.test("variant payload rest works through the or-pattern path", () => { + Test_utils.eq("File \"record_rest_test.res\", line 257, 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 262, 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 270, 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 275, characters 6-13", getInlineWrappedRest({ + TAG: "InlineMirror", + name: "inlineMirror", + version: "8.0", + debug: false + }), { + version: "8.0", + debug: false + }); + }); + Mocha.test("inline record variant rest excludes fields renamed with @as", () => { + Test_utils.eq("File \"record_rest_test.res\", line 283, 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 290, 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 300, 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 307, characters 6-13", getCustomTaggedInlineWrappedRest({ + kind: "CustomInlineMirror", + name: "customInlineMirror", + version: "10.0", + debug: false + }), { + version: "10.0", + debug: false + }); + }); + Mocha.test("inline record rest works with a non-identifier custom tag name", () => { + Test_utils.eq("File \"record_rest_test.res\", line 317, 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 324, characters 6-13", getDashedTaggedInlineWrappedRest({ + "custom-tag": "DashedInlineMirror", + name: "dashedInlineMirror", + version: "12.0", + debug: false + }), { + version: "12.0", + debug: false + }); + }); + Mocha.test("strict directive functions keep record rest destructuring in the body", () => { + let strictDirectiveRest = param => { + 'use strict'; + let {name: __unused0, ...rest} = param; + return rest; + }; + Test_utils.eq("File \"record_rest_test.res\", line 337, characters 6-13", strictDirectiveRest({ + name: "strict", + version: "13.0", + debug: false + }), { + version: "13.0", + debug: false + }); + }); +}); + +export { + RestConfig, + describeConfig, + getNameAndRestConfig, + getAliasedRest, + getNamespacedRest, + getRenamedRest, + getRenamedNameAndRest, + getName, + getWholeConfig, + makeConfig, + getCallResultRest, + getNameRestAndOriginalVersion, + extractClassName, + getValue, + getTupleRest, + getWrappedRest, + getInlineWrappedRest, + getRenamedInlineWrappedRest, + getCustomTaggedInlineWrappedRest, + getDashedTaggedInlineWrappedRest, +} +/* Not a pure module */ diff --git a/tests/tests/src/record_rest_test.res b/tests/tests/src/record_rest_test.res new file mode 100644 index 00000000000..79cd4553241 --- /dev/null +++ b/tests/tests/src/record_rest_test.res @@ -0,0 +1,342 @@ +open Mocha +open Test_utils + +type config = { + name: string, + version: string, + debug: bool, +} + +type restConfig = { + version: string, + debug: bool, +} + +module RestConfig = { + type t = { + version: string, + debug: bool, + } +} + +type aliasedRestConfig = restConfig + +type renamedConfig = { + @as("user-name") + name: string, + version: string, + debug: bool, +} + +let describeConfig = (c: config) => + switch c { + | {name, ...restConfig as rest} => (name, rest) + } + +let getNameAndRestConfig = ({name, ...restConfig as restConfig}: config) => (name, restConfig) + +let getAliasedRest = ({name: _, ...aliasedRestConfig as rest}: config) => rest +let getNamespacedRest = ({name: _, ...RestConfig.t as rest}: config) => rest + +let getRenamedRest = ({name: _, ...restConfig as rest}: renamedConfig) => rest +let getRenamedNameAndRest = ({name, ...restConfig as rest}: renamedConfig) => (name, rest) + +let getName = ({name, ...restConfig as _rest}: config) => name +let getWholeConfig = ({...config as rest}: config) => rest +let makeConfig = (): config => {name: "call", version: "4.5", debug: true} +let getCallResultRest = () => { + let {name: _, ...restConfig as rest} = makeConfig() + rest +} + +let getNameRestAndOriginalVersion = ({name, ...restConfig as rest} as original: config) => ( + name, + rest, + original.version, +) + +type fullProps = { + className?: string, + style?: string, + onClick: unit => unit, +} + +type baseProps = { + className?: string, + style?: string, + onClick: unit => unit, +} + +@warning("-112") +let extractClassName = ({className: ?_, ...baseProps as rest}: fullProps) => rest + +type container<'a> = { + id: string, + value: 'a, +} + +type valueContainer<'a> = { + value: 'a, +} + +let getValue = ({id: _, ...valueContainer<'a> as rest}: container<'a>) => rest + +type wrapped = + | Wrap(config) + | Mirror(config) + +let getTupleRest = (({name: _, ...restConfig as rest}, _): (config, int)) => rest + +let getWrappedRest = wrapped => + switch wrapped { + | Wrap({name: _, ...restConfig as rest}) + | Mirror({name: _, ...restConfig as rest}) => rest + } + +type inlineWrapped = + | InlineWrap({name: string, version: string, debug: bool}) + | InlineMirror({name: string, version: string, debug: bool}) + +let getInlineWrappedRest = wrapped => + switch wrapped { + | InlineWrap({name: _, ...restConfig as rest}) + | InlineMirror({name: _, ...restConfig 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: _, ...restConfig as rest}) + | RenamedInlineMirror({name: _, ...restConfig 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: _, ...restConfig as rest}) + | CustomInlineMirror({name: _, ...restConfig 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: _, ...restConfig as rest}) + | DashedInlineMirror({name: _, ...restConfig as rest}) => rest + } + +describe(__MODULE__, () => { + test("let binding captures record rest value", () => { + let {name, ...restConfig 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("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 accepts namespaced record types", () => { + eq( + __LOC__, + getNamespacedRest({name: "namespaced", version: "3.15", debug: true}), + {version: "3.15", debug: true}, + ) + + let {name: _, ...RestConfig.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__, + getRenamedRest({name: "renamed", version: "3.2", debug: true}), + {version: "3.2", debug: true}, + ) + }) + + test("record rest can return a field renamed with @as alongside the rest", () => { + eq( + __LOC__, + getRenamedNameAndRest({name: "renamed", version: "3.25", debug: false}), + ("renamed", {version: "3.25", debug: false}), + ) + }) + + 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("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}) + 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("record rest works when the source is not a bare identifier", () => { + eq(__LOC__, getCallResultRest(), {version: "4.5", debug: true}) + }) + + test("record rest keeps the original parameter alias usable", () => { + eq( + __LOC__, + getNameRestAndOriginalVersion({name: "original", version: "4.75", debug: false}), + ("original", {version: "4.75", debug: false}, "4.75"), + ) + }) + + 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 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__, + 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}, + ) + }) + + 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}, + ) + }) + + test("strict directive functions keep record rest destructuring in the body", () => { + let strictDirectiveRest = + @directive("'use strict'") ({name: _, ...restConfig as rest}: config) => rest + + eq( + __LOC__, + strictDirectiveRest({name: "strict", version: "13.0", debug: false}), + {version: "13.0", debug: false}, + ) + }) +}) 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..79c1362adfd --- /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 {name, ...rest} = param; + return [ + name, + rest + ]; +} + +exports.extract = extract; +/* No side effect */