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..a10a3f8d909 100644 --- a/analysis/reanalyze/src/dead_value.ml +++ b/analysis/reanalyze/src/dead_value.ml @@ -235,7 +235,7 @@ let collect_pattern ~config ~refs : fun super self pat -> let pos_from = pat.Typedtree.pat_loc.loc_start in (match pat.pat_desc with - | Typedtree.Tpat_record (cases, _clodsedFlag) -> + | Typedtree.Tpat_record (cases, _clodsedFlag, _rest) -> cases |> List.iter (fun (_loc, {Types.lbl_loc = {loc_start = pos_to}}, _pat, _) -> if !Config.analyze_types then diff --git a/analysis/src/completion_front_end.ml b/analysis/src/completion_front_end.ml index aeaf7657903..e0bc67bce69 100644 --- a/analysis/src/completion_front_end.ml +++ b/analysis/src/completion_front_end.ml @@ -517,7 +517,7 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file (NPolyvariantPayload {item_num = 0; constructor_name = txt} :: pattern_path) ?context_path p - | Ppat_record (fields, _) -> + | Ppat_record (fields, _, _rest) -> Ext_list.iter fields (fun {lid = fname; x = p} -> match fname with | {Location.txt = Longident.Lident fname} -> diff --git a/analysis/src/completion_patterns.ml b/analysis/src/completion_patterns.ml index cc1a270cab7..16b6ae886df 100644 --- a/analysis/src/completion_patterns.ml +++ b/analysis/src/completion_patterns.ml @@ -106,12 +106,12 @@ and traverse_pattern (pat : Parsetree.pattern) ~pattern_path ~loc_has_cursor [Completable.NTupleItem {item_num}] @ pattern_path) ~result_from_found_item_num:(fun item_num -> [Completable.NTupleItem {item_num = item_num + 1}] @ pattern_path) - | Ppat_record ([], _) -> + | Ppat_record ([], _, _rest) -> (* Empty fields means we're in a record body `{}`. Complete for the fields. *) some_if_has_cursor ("", [Completable.NRecordBody {seen_fields = []}] @ pattern_path) "Ppat_record(empty)" - | Ppat_record (fields, _) -> ( + | Ppat_record (fields, _, _rest) -> ( let field_with_cursor = ref None in let field_with_pat_hole = ref None in Ext_list.iter fields (fun {lid = fname; x = f} -> diff --git a/analysis/src/dump_ast.ml b/analysis/src/dump_ast.ml index 0ebb44c0d5a..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..754eb2533c0 100644 --- a/compiler/common/pattern_printer.ml +++ b/compiler/common/pattern_printer.ml @@ -76,7 +76,7 @@ let untype typed = | Tpat_variant (label, p_opt, _row_desc) -> let arg = Option.map loop p_opt in mkpat (Ppat_variant (label, arg)) - | Tpat_record (subpatterns, closed_flag) -> + | Tpat_record (subpatterns, closed_flag, _rest) -> let fields, saw_optional_rewrite = List.fold_right (fun (_, lbl, p, opt) (fields, saw_optional_rewrite) -> @@ -97,7 +97,7 @@ let untype typed = subpatterns ([], false) in let closed_flag = if saw_optional_rewrite then Closed else closed_flag in - mkpat (Ppat_record (fields, closed_flag)) + mkpat (Ppat_record (fields, closed_flag, None)) | Tpat_array lst -> mkpat (Ppat_array (List.map loop lst)) in loop typed diff --git a/compiler/core/j.ml b/compiler/core/j.ml index f20b22ec727..644756665fe 100644 --- a/compiler/core/j.ml +++ b/compiler/core/j.ml @@ -77,6 +77,18 @@ and property_map = (property_name * expression) list and length_object = Js_op.length_object and delim = External_arg_spec.delim = DNone | DStarJ | DNoQuotes | DBackQuotes +and record_rest_field = { + record_rest_label: string; + record_rest_ident: ident option; +} + +and object_rest_param = { + object_rest_fields: record_rest_field list; + object_rest_rest: ident; +} + +and param = Ident_param of ident | Object_rest_param of object_rest_param + and expression_desc = | Length of expression * length_object | Is_null_or_undefined of expression (** where we use a trick [== null ] *) @@ -132,7 +144,7 @@ and expression_desc = | Var of vident | Fun of { is_method: bool; - params: ident list; + params: param list; body: block; env: Js_fun_env.t; return_unit: bool; @@ -165,6 +177,7 @@ and expression_desc = | Null | Await of expression | Spread of expression + | Record_rest of record_rest_field list * expression and for_ident_expression = expression (* pure*) @@ -327,6 +340,9 @@ and deps_program = { finish_ident_expression; property_map; length_object; + record_rest_field; + object_rest_param; + param; (* for_ident; *) required_modules; case_clause; @@ -337,3 +353,23 @@ FIXME: customize for each code generator for each code generator, we can provide a white-list so that we can achieve the optimal *) + +let record_rest_field_idents fields = + List.filter_map (fun {record_rest_ident} -> record_rest_ident) fields + +let object_rest_param_idents {object_rest_fields; object_rest_rest} = + object_rest_rest :: record_rest_field_idents object_rest_fields + +let param_idents = function + | Ident_param id -> [id] + | Object_rest_param param -> object_rest_param_idents param + +let params_idents params = List.concat_map param_idents params + +let params_as_idents params = + let rec aux acc = function + | [] -> Some (List.rev acc) + | Ident_param id :: rest -> aux (id :: acc) rest + | Object_rest_param _ :: _ -> None + in + aux [] params diff --git a/compiler/core/js_analyzer.ml b/compiler/core/js_analyzer.ml index 25852412667..e51552d772d 100644 --- a/compiler/core/js_analyzer.ml +++ b/compiler/core/js_analyzer.ml @@ -30,6 +30,14 @@ type idents_stats = { let add_defined_idents (x : idents_stats) ident = x.defined_idents <- Set_ident.add x.defined_idents ident +let add_record_rest_field_idents stats fields = + List.iter + (fun (field : J.record_rest_field) -> + match field.record_rest_ident with + | None -> () + | Some ident -> add_defined_idents stats ident) + fields + (* Assume that functions already calculated closure correctly Maybe in the future, we should add a dirty flag, to mark the calcuated closure is correct or not @@ -46,6 +54,9 @@ let free_variables (stats : idents_stats) = (fun self st -> add_defined_idents stats st.ident; match st.value with + | Some {expression_desc = Record_rest (fields, source)} -> + add_record_rest_field_idents stats fields; + self.expression self source | None -> () | Some v -> self.expression self v); ident = @@ -118,6 +129,7 @@ let rec no_side_effect_expression_desc (x : J.expression_desc) = | FlatCall _ | Call _ | New _ | Raw_js_code _ (* actually true? *) -> false | Await _ -> false | Spread _ -> false + | Record_rest _ -> false and no_side_effect (x : J.expression) = no_side_effect_expression_desc x.expression_desc @@ -230,7 +242,8 @@ let rec eq_expression ({expression_desc = x0} : J.expression) | _ -> false) | Length _ | Is_null_or_undefined _ | String_append _ | Typeof _ | Js_not _ | Js_bnot _ | In _ | Cond _ | FlatCall _ | New _ | Fun _ | Raw_js_code _ - | Array _ | Caml_block_tag _ | Object _ | Tagged_template _ | Await _ -> + | Array _ | Caml_block_tag _ | Object _ | Tagged_template _ | Await _ + | Record_rest _ -> false | Spread _ -> false diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index 6f6da8b605c..1ceb8615867 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -172,6 +172,7 @@ let rec exp_need_paren ?(arrow = false) (e : J.expression) = | Await _ -> false | Spread _ -> false | Tagged_template _ -> false + | Record_rest _ -> false | Optional_block (e, true) when arrow -> exp_need_paren ~arrow e | Optional_block _ -> false @@ -237,7 +238,43 @@ let debugger_nl f = semi f; P.newline f -let formal_parameter_list cxt f l = iter_lst cxt f l Ext_pp_scope.ident comma_sp +let rec record_rest_field cxt f + ({record_rest_label; record_rest_ident} : J.record_rest_field) = + let key = Js_dump_property.property_key (Lit record_rest_label) in + match record_rest_ident with + | None -> + P.string f key; + cxt + | Some id -> + let str, cxt = Ext_pp_scope.str_of_ident cxt id in + if key = str then P.string f key + else ( + P.string f key; + P.string f L.colon_space; + P.string f str); + cxt + +and record_rest_pattern cxt f fields rest = + P.string f "{"; + let cxt = + match fields with + | [] -> cxt + | _ -> + let cxt = iter_lst cxt f fields record_rest_field comma_sp in + comma_sp f; + cxt + in + P.string f "..."; + let cxt = Ext_pp_scope.ident cxt f rest in + P.string f "}"; + cxt + +and param cxt f = function + | J.Ident_param id -> Ext_pp_scope.ident cxt f id + | Object_rest_param {object_rest_fields; object_rest_rest} -> + record_rest_pattern cxt f object_rest_fields object_rest_rest + +and formal_parameter_list cxt f l = iter_lst cxt f l param comma_sp (* IdentMap *) (* @@ -269,6 +306,20 @@ let is_var (b : J.expression) a = | Var (Id i) -> Ident.same i a | _ -> false +let params_match_call params args fn = + match J.params_as_idents params with + | Some params -> ( + Ext_list.for_all2_no_exn args params is_var + && + match fn with + (* This check is needed to avoid some edge cases + {[function(x){return x(x)}]} + here the function is also called `x` + *) + | J.Id id -> not (Ext_list.exists params (fun x -> Ident.same x id)) + | Qualified _ -> true) + | None -> false + type fn_exp_state = | Is_return (* for sure no name *) | Name_top of Ident.t @@ -286,7 +337,7 @@ let rec try_optimize_curry cxt f len function_id = P.paren_group f 1 (fun _ -> expression ~level:1 cxt f function_id) and pp_function ~return_unit ~async ~is_method ?directive cxt (f : P.t) - ~fn_state (l : Ident.t list) (b : J.block) (env : Js_fun_env.t) : cxt = + ~fn_state (l : J.param list) (b : J.block) (env : Js_fun_env.t) : cxt = match b with | [ { @@ -309,16 +360,7 @@ and pp_function ~return_unit ~async ~is_method ?directive cxt (f : P.t) {[ function(x,y){ return u(x,y) } ]} it can be optimized in to either [u] or [Curry.__n(u)] *) - (not is_method) - && Ext_list.for_all2_no_exn ls l is_var - && - match v with - (* This check is needed to avoid some edge cases - {[function(x){return x(x)}]} - here the function is also called `x` - *) - | Id id -> not (Ext_list.exists l (fun x -> Ident.same x id)) - | Qualified _ -> true -> ( + (not is_method) && params_match_call l ls v -> ( let optimize len ~p cxt f v = if p then try_optimize_curry cxt f len function_id else vident cxt f v in @@ -359,10 +401,10 @@ and pp_function ~return_unit ~async ~is_method ?directive cxt (f : P.t) *) let inner_cxt = Ext_pp_scope.sub_scope outer_cxt set_env in let param_body () : unit = - if is_method then ( + if is_method then match l with | [] -> assert false - | this :: arguments -> + | Ident_param this :: arguments -> let cxt = P.paren_group f 1 (fun _ -> formal_parameter_list inner_cxt f arguments) @@ -373,11 +415,13 @@ and pp_function ~return_unit ~async ~is_method ?directive cxt (f : P.t) if Js_fun_env.get_unused env 0 then cxt else pp_var_assign_this cxt f this in - function_body ?directive ~return_unit cxt f b)) + function_body ?directive ~return_unit cxt f b) + | Object_rest_param _ :: _ -> assert false else let cxt = match l with - | [single] when arrow -> Ext_pp_scope.ident inner_cxt f single + | [Ident_param single] when arrow -> + Ext_pp_scope.ident inner_cxt f single | l -> P.paren_group f 1 (fun _ -> formal_parameter_list inner_cxt f l) in @@ -494,6 +538,25 @@ and expression_desc cxt ~(level : int) f x : cxt = P.string f L.undefined; cxt | Var v -> vident cxt f v + | Record_rest (fields, source) -> + P.cond_paren_group f (level > 15) (fun _ -> + P.string f "(({"; + fields + |> List.iteri (fun i ({record_rest_label; _} : J.record_rest_field) -> + if i > 0 then comma_sp f; + let key = + Js_dump_property.property_key (Lit record_rest_label) + in + P.string f key; + P.string f L.colon_space; + P.string f ("__unused" ^ string_of_int i)); + (match fields with + | [] -> () + | _ -> comma_sp f); + P.string f "...__rest}) => __rest)("; + let cxt = expression ~level:0 cxt f source in + P.string f ")"; + cxt) | Bool b -> bool f b; cxt @@ -1294,6 +1357,16 @@ and variable_declaration top cxt f (variable : J.variable_declaration) : cxt = pp_function ?directive ~is_method ~return_unit ~async ~fn_state:(if top then Name_top name else Name_non_top name) cxt f params body env + | Record_rest (fields, source) -> + P.string f L.let_; + P.space f; + let cxt = record_rest_pattern cxt f fields name in + P.space f; + P.string f L.eq; + P.space f; + let cxt = expression ~level:1 cxt f source in + semi f; + cxt | _ -> let cxt = pp_var_assign cxt f name in let cxt = expression ~level:1 cxt f e in diff --git a/compiler/core/js_exp_make.ml b/compiler/core/js_exp_make.ml index 530765477ed..711ce215e4b 100644 --- a/compiler/core/js_exp_make.ml +++ b/compiler/core/js_exp_make.ml @@ -166,6 +166,10 @@ let raw_js_code ?comment info s : t = } let array ?comment mt es : t = {expression_desc = Array (es, mt); comment} + +let record_rest ?comment fields source : t = + {expression_desc = Record_rest (fields, source); comment} + let some_comment = None let optional_block e : J.expression = @@ -239,6 +243,7 @@ let ocaml_fun ?comment ?immutable_mask ?directive ~return_unit ~async ~one_unit_arg params body : t = let params = if one_unit_arg then [] else params in let len = List.length params in + let params = List.map (fun id -> J.Ident_param id) params in { expression_desc = Fun @@ -256,6 +261,7 @@ let ocaml_fun ?comment ?immutable_mask ?directive ~return_unit ~async let method_ ?comment ?immutable_mask ~async ~return_unit params body : t = let len = List.length params in + let params = List.map (fun id -> J.Ident_param id) params in { expression_desc = Fun diff --git a/compiler/core/js_exp_make.mli b/compiler/core/js_exp_make.mli index d37d55ea9a8..84ffed98d61 100644 --- a/compiler/core/js_exp_make.mli +++ b/compiler/core/js_exp_make.mli @@ -97,6 +97,8 @@ val runtime_ref : string -> string -> t val str : ?delim:J.delim -> ?comment:string -> string -> t +val record_rest : ?comment:string -> J.record_rest_field list -> t -> t + val ocaml_fun : ?comment:string -> ?immutable_mask:bool array -> diff --git a/compiler/core/js_fold.ml b/compiler/core/js_fold.ml index e080f501196..25280fa0e7e 100644 --- a/compiler/core/js_fold.ml +++ b/compiler/core/js_fold.ml @@ -83,6 +83,26 @@ class fold = method length_object : length_object -> 'self_type = unknown _self + method record_rest_field : record_rest_field -> 'self_type = + fun {record_rest_ident = _x0; _} -> + let _self = option (fun _self -> _self#ident) _self _x0 in + _self + + method object_rest_param : object_rest_param -> 'self_type = + fun {object_rest_fields = _x0; object_rest_rest = _x1} -> + let _self = list (fun _self -> _self#record_rest_field) _self _x0 in + let _self = _self#ident _x1 in + _self + + method param : param -> 'self_type = + function + | Ident_param _x0 -> + let _self = _self#ident _x0 in + _self + | Object_rest_param _x0 -> + let _self = _self#object_rest_param _x0 in + _self + method expression_desc : expression_desc -> 'self_type = function | Length (_x0, _x1) -> @@ -159,7 +179,7 @@ class fold = let _self = _self#vident _x0 in _self | Fun {params = x1; body = x2} -> - let _self = list (fun _self -> _self#ident) _self x1 in + let _self = list (fun _self -> _self#param) _self x1 in let _self = _self#block x2 in _self | Str _ -> _self @@ -190,6 +210,9 @@ class fold = | Spread _x0 -> let _self = _self#expression _x0 in _self + | Record_rest (_x0, _x1) -> + let _self = _self#expression _x1 in + _self method for_ident_expression : for_ident_expression -> 'self_type = _self#expression diff --git a/compiler/core/js_pass_flatten_and_mark_dead.ml b/compiler/core/js_pass_flatten_and_mark_dead.ml index 30424e68abd..22c0592e346 100644 --- a/compiler/core/js_pass_flatten_and_mark_dead.ml +++ b/compiler/core/js_pass_flatten_and_mark_dead.ml @@ -29,6 +29,14 @@ type meta_info = Info of J.ident_info | Recursive let super = Js_record_iter.super +let add_binding_info ident_use_stats ident_info ident = + match Hash_ident.find_opt ident_use_stats ident with + | Some Recursive -> + Js_op_util.update_used_stats ident_info Used; + Hash_ident.replace ident_use_stats ident (Info ident_info) + | Some (Info _) -> () + | None -> Hash_ident.add ident_use_stats ident (Info ident_info) + let mark_dead_code (js : J.program) : J.program = let ident_use_stats : meta_info Hash_ident.t = Hash_ident.create 17 in let mark_dead = @@ -64,21 +72,32 @@ let mark_dead_code (js : J.program) : J.program = if Set_ident.mem js.export_set ident then Js_op_util.update_used_stats ident_info Exported in - match Hash_ident.find_opt ident_use_stats ident with - | Some Recursive -> - Js_op_util.update_used_stats ident_info Used; - Hash_ident.replace ident_use_stats ident (Info ident_info) - | Some (Info _) -> - (* check [camlinternlFormat,box_type] inlined twice - FIXME: seems we have redeclared identifiers - *) - () - (* assert false *) - | None -> - (* First time *) - Hash_ident.add ident_use_stats ident (Info ident_info); - Js_op_util.update_used_stats ident_info - (if pure then Scanning_pure else Scanning_non_pure))); + let () = + match Hash_ident.find_opt ident_use_stats ident with + | Some Recursive -> + Js_op_util.update_used_stats ident_info Used; + Hash_ident.replace ident_use_stats ident (Info ident_info) + | Some (Info _) -> + (* check [camlinternlFormat,box_type] inlined twice + FIXME: seems we have redeclared identifiers + *) + () + (* assert false *) + | None -> + (* First time *) + Hash_ident.add ident_use_stats ident (Info ident_info); + Js_op_util.update_used_stats ident_info + (if pure then Scanning_pure else Scanning_non_pure) + in + match value with + | Some {expression_desc = Record_rest (fields, _)} -> + fields + |> List.iter (fun (field : J.record_rest_field) -> + match field.record_rest_ident with + | None -> () + | Some ident -> + add_binding_info ident_use_stats ident_info ident) + | _ -> ())); } in mark_dead.program mark_dead js; diff --git a/compiler/core/js_pass_record_rest.ml b/compiler/core/js_pass_record_rest.ml new file mode 100644 index 00000000000..2d5a60c30e9 --- /dev/null +++ b/compiler/core/js_pass_record_rest.ml @@ -0,0 +1,193 @@ +module E = Js_exp_make +open J + +let field_ident_name i label = + if Js_dump_property.property_key (Lit label) = label then label + else "__rest_field" ^ string_of_int i + +let ignored_ident i = Ext_ident.create ("__unused" ^ string_of_int i) + +let uses_ident ident block = + let found = ref false in + let obj = + { + Js_record_iter.super with + ident = + (fun _ candidate -> if Ident.same ident candidate then found := true); + } + in + obj.block obj block; + !found + +let materialize_fields source fields tail = + match source.J.expression_desc with + | Var (Id source_ident) -> + let used_fields = Hashtbl.create 7 in + let field_names = + List.mapi (fun i field -> (field.J.record_rest_label, i)) fields + in + let find_field_index label = List.assoc_opt label field_names in + let get_field_ident label = + match Hashtbl.find_opt used_fields label with + | Some ident -> ident + | None -> + let i = + match find_field_index label with + | Some i -> i + | None -> assert false + in + let ident = Ext_ident.create (field_ident_name i label) in + Hashtbl.add used_fields label ident; + ident + in + let replace = + { + Js_record_map.super with + expression = + (fun self expr -> + match expr.expression_desc with + | Static_index ({expression_desc = Var (Id ident); _}, label, _) + when Ident.same ident source_ident + && find_field_index label <> None -> + E.var (get_field_ident label) + | _ -> Js_record_map.super.expression self expr); + } + in + let tail = replace.block replace tail in + let fields = + List.mapi + (fun i field -> + match field.J.record_rest_ident with + | Some _ -> field + | None -> + let ident = + match Hashtbl.find_opt used_fields field.record_rest_label with + | Some ident -> ident + | None -> ignored_ident i + in + {field with record_rest_ident = Some ident}) + fields + in + (fields, tail) + | _ -> + let fields = + List.mapi + (fun i field -> + match field.J.record_rest_ident with + | Some _ -> field + | None -> {field with record_rest_ident = Some (ignored_ident i)}) + fields + in + (fields, tail) + +let pass = + let super = Js_record_map.super in + let block (self : Js_record_map.iter) = function + | ({ + statement_desc = + Variable + ({ + value = + Some + ({expression_desc = Record_rest (fields, source); _} as + value); + _; + } as variable); + _; + } as statement) + :: tail -> + let source = self.expression self source in + let tail = self.block self tail in + let fields, tail = materialize_fields source fields tail in + { + statement with + statement_desc = + Variable + { + variable with + value = + Some {value with expression_desc = Record_rest (fields, source)}; + }; + } + :: tail + | statement :: tail -> self.statement self statement :: self.block self tail + | [] -> [] + in + { + super with + block; + expression = + (fun self expr -> + match expr.expression_desc with + | Fun ({is_method = false; params = [Ident_param param]; body} as fun_) + -> + let body = self.block self body in + let params, body = + match body with + | { + statement_desc = + Variable + { + ident = rest; + value = + Some + { + expression_desc = + Record_rest + (fields, {expression_desc = Var (Id source); _}); + _; + }; + _; + }; + _; + } + :: tail + when Ident.name param = "param" + && Ident.same param source + && not (uses_ident param tail) -> + ( [ + Object_rest_param + {object_rest_fields = fields; object_rest_rest = rest}; + ], + tail ) + | [ + { + statement_desc = + Return + ({ + expression_desc = + Record_rest + ( fields, + ({expression_desc = Var (Id source); _} as + source_expr) ); + _; + } as rest_expr); + _; + }; + ] + when Ident.name param = "param" && Ident.same param source -> + let rest = Ext_ident.create "rest" in + let fields, body = + materialize_fields source_expr fields + [ + { + statement_desc = Return (E.var rest); + comment = rest_expr.comment; + }; + ] + in + ( [ + Object_rest_param + {object_rest_fields = fields; object_rest_rest = rest}; + ], + body ) + | _ -> (fun_.params, body) + in + {expr with expression_desc = Fun {fun_ with params; body}} + | Fun ({body} as fun_) -> + let body = self.block self body in + {expr with expression_desc = Fun {fun_ with body}} + | _ -> super.expression self expr); + } + +let program program = pass.program pass program diff --git a/compiler/core/js_pass_scope.ml b/compiler/core/js_pass_scope.ml index 004f3e5b040..b246e43fbc0 100644 --- a/compiler/core/js_pass_scope.ml +++ b/compiler/core/js_pass_scope.ml @@ -129,6 +129,8 @@ let add_defined_ident (st : state) id = let add_used_ident (st : state) id = {st with used_idents = Set_ident.add st.used_idents id} +let add_defined_idents st ids = List.fold_left add_defined_ident st ids + let super = Js_record_fold.super let record_scope_pass = @@ -146,14 +148,17 @@ let record_scope_pass = *) (* Note that [used_idents] is not complete it ignores some locally defined idents *) - let param_set = Set_ident.of_list params in + let param_idents = J.params_idents params in + let param_set = Set_ident.of_list param_idents in let {defined_idents = defined_idents'; used_idents = used_idents'} = + let mutable_params = + match J.params_as_idents params with + | None -> Set_ident.empty + | Some params -> + Set_ident.of_list (Js_fun_env.get_mutable_params params env) + in self.block self - { - init_state with - mutable_values = - Set_ident.of_list (Js_fun_env.get_mutable_params params env); - } + {init_state with mutable_values = mutable_params} body in (* let defined_idents', used_idents' = @@ -161,8 +166,12 @@ let record_scope_pass = (* mark which param is used *) params |> List.iteri (fun i v -> - if not (Set_ident.mem used_idents' v) then - Js_fun_env.mark_unused env i); + if + not + (List.exists + (fun ident -> Set_ident.mem used_idents' ident) + (J.param_idents v)) + then Js_fun_env.mark_unused env i); let closured_idents' = (* pass param_set down *) Set_ident.(diff used_idents' (union defined_idents' param_set)) @@ -189,25 +198,32 @@ let record_scope_pass = (fun self state x -> match x with | {ident; value; property} -> ( + let record_rest_idents = + match value with + | Some {expression_desc = Record_rest (fields, _)} -> + J.record_rest_field_idents fields + | _ -> [] + in let obj = - add_defined_ident - (match (state.in_loop, property) with - | true, Variable -> add_loop_mutable_variable state ident - | true, (Strict | StrictOpt | Alias) - (* Not real true immutable in javascript + add_defined_idents + (add_defined_ident + (match (state.in_loop, property) with + | true, Variable -> add_loop_mutable_variable state ident + | true, (Strict | StrictOpt | Alias) + (* Not real true immutable in javascript since it's in the loop TODO: we should also *) - -> ( - match value with - | None -> - add_loop_mutable_variable state ident - (* TODO: Check why assertion failure *) - (* self#add_loop_mutable_variable ident *) - (* assert false *) - | Some x -> ( - (* + -> ( + match value with + | None -> + add_loop_mutable_variable state ident + (* TODO: Check why assertion failure *) + (* self#add_loop_mutable_variable ident *) + (* assert false *) + | Some x -> ( + (* when x is an immediate immutable value, (like integer .. ) not a reference, it should be Immutable @@ -215,22 +231,23 @@ let record_scope_pass = type system might help here TODO: *) - match x.expression_desc with - | Fun _ | Number _ | Str _ -> state - | _ -> - (* if Set_ident.(is_empty @@ *) - (* inter self#get_mutable_values *) - (* ( ({< *) - (* defined_idents = Set_ident.empty; *) - (* used_idents = Set_ident.empty; *) - (* >} # expression x) # get_used_idents)) then *) - (* (\* FIXME: still need to check expression is pure or not*\) *) - (* self *) - (* else *) - add_loop_mutable_variable state ident)) - | false, Variable -> add_mutable_variable state ident - | false, (Strict | StrictOpt | Alias) -> state) - ident + match x.expression_desc with + | Fun _ | Number _ | Str _ -> state + | _ -> + (* if Set_ident.(is_empty @@ *) + (* inter self#get_mutable_values *) + (* ( ({< *) + (* defined_idents = Set_ident.empty; *) + (* used_idents = Set_ident.empty; *) + (* >} # expression x) # get_used_idents)) then *) + (* (\* FIXME: still need to check expression is pure or not*\) *) + (* self *) + (* else *) + add_loop_mutable_variable state ident)) + | false, Variable -> add_mutable_variable state ident + | false, (Strict | StrictOpt | Alias) -> state) + ident) + record_rest_idents in match value with | None -> obj diff --git a/compiler/core/js_pass_tailcall_inline.ml b/compiler/core/js_pass_tailcall_inline.ml index 5a92b05cac1..b60b4cf8919 100644 --- a/compiler/core/js_pass_tailcall_inline.ml +++ b/compiler/core/js_pass_tailcall_inline.ml @@ -78,6 +78,11 @@ let inline_call (immutable_list : bool list) params (args : J.expression list) let obj = substitue_variables map in obj.block obj block +let simple_params_exn params = + match J.params_as_idents params with + | Some params -> params + | None -> assert false + (** There is a side effect when traversing dead code, since we assume that substitue a node would mark a node as dead node, @@ -182,13 +187,16 @@ let subst (export_set : Set_ident.t) stats = ident_info = {used_stats = Once_pure}; ident = _; } as v) - when Ext_list.same_length params args -> + when match J.params_as_idents params with + | Some params -> Ext_list.same_length params args + | None -> false -> Js_op_util.update_used_stats v.ident_info Dead_pure; let no_tailcall = Js_fun_env.no_tailcall env in let processed_blocks = self.block self body (* see #278 before changes*) in + let params = simple_params_exn params in inline_call no_tailcall params args processed_blocks (* Ext_list.fold_right2 params args processed_blocks @@ -222,12 +230,15 @@ let subst (export_set : Set_ident.t) stats = }; }; ] - when Ext_list.same_length params args -> + when match J.params_as_idents params with + | Some params -> Ext_list.same_length params args + | None -> false -> let no_tailcall = Js_fun_env.no_tailcall env in let processed_blocks = self.block self body (* see #278 before changes*) in + let params = simple_params_exn params in inline_call no_tailcall params args processed_blocks | x :: xs -> self.statement self x :: self.block self xs | [] -> []); diff --git a/compiler/core/js_record_fold.ml b/compiler/core/js_record_fold.ml index d3e0de74358..994ca79b177 100644 --- a/compiler/core/js_record_fold.ml +++ b/compiler/core/js_record_fold.ml @@ -89,6 +89,21 @@ let property_map : 'a. ('a, property_map) fn = let length_object : 'a. ('a, length_object) fn = unknown +let record_rest_field : 'a. ('a, record_rest_field) fn = + fun _self st {record_rest_ident; _} -> + option _self.ident _self st record_rest_ident + +let object_rest_param : 'a. ('a, object_rest_param) fn = + fun _self st {object_rest_fields; object_rest_rest} -> + let st = list record_rest_field _self st object_rest_fields in + let st = _self.ident _self st object_rest_rest in + st + +let param : 'a. ('a, param) fn = + fun _self st -> function + | Ident_param id -> _self.ident _self st id + | Object_rest_param rest -> object_rest_param _self st rest + let expression_desc : 'a. ('a, expression_desc) fn = fun _self st -> function | Length (_x0, _x1) -> @@ -165,7 +180,7 @@ let expression_desc : 'a. ('a, expression_desc) fn = let st = _self.vident _self st _x0 in st | Fun {params; body} -> - let st = list _self.ident _self st params in + let st = list param _self st params in let st = _self.block _self st body in st | Str _ -> st @@ -196,6 +211,9 @@ let expression_desc : 'a. ('a, expression_desc) fn = | Spread _x0 -> let st = _self.expression _self st _x0 in st + | Record_rest (_x0, _x1) -> + let st = _self.expression _self st _x1 in + st let for_ident_expression : 'a. ('a, for_ident_expression) fn = fun _self arg -> _self.expression _self arg diff --git a/compiler/core/js_record_iter.ml b/compiler/core/js_record_iter.ml index da86618ae3c..f925e5ab370 100644 --- a/compiler/core/js_record_iter.ml +++ b/compiler/core/js_record_iter.ml @@ -79,6 +79,19 @@ let property_map : property_map fn = let length_object : length_object fn = unknown +let record_rest_field : record_rest_field fn = + fun _self {record_rest_ident; _} -> option _self.ident _self record_rest_ident + +let object_rest_param : object_rest_param fn = + fun _self {object_rest_fields; object_rest_rest} -> + list record_rest_field _self object_rest_fields; + _self.ident _self object_rest_rest + +let param : param fn = + fun _self -> function + | Ident_param id -> _self.ident _self id + | Object_rest_param rest -> object_rest_param _self rest + let expression_desc : expression_desc fn = fun _self -> function | Length (_x0, _x1) -> @@ -127,7 +140,7 @@ let expression_desc : expression_desc fn = option (fun _self arg -> list _self.expression _self arg) _self _x1 | Var _x0 -> _self.vident _self _x0 | Fun {params; body} -> - list _self.ident _self params; + list param _self params; _self.block _self body | Str _ -> () | Raw_js_code _ -> () @@ -145,6 +158,7 @@ let expression_desc : expression_desc fn = | Null -> () | Await _x0 -> _self.expression _self _x0 | Spread _x0 -> _self.expression _self _x0 + | Record_rest (_x0, _x1) -> _self.expression _self _x1 let for_ident_expression : for_ident_expression fn = fun _self arg -> _self.expression _self arg diff --git a/compiler/core/js_record_map.ml b/compiler/core/js_record_map.ml index 26551861718..4e1d19deb62 100644 --- a/compiler/core/js_record_map.ml +++ b/compiler/core/js_record_map.ml @@ -89,6 +89,26 @@ let property_map : property_map fn = let length_object : length_object fn = unknown +let record_rest_field : record_rest_field fn = + fun _self ({record_rest_ident} as field) -> + let record_rest_ident = option _self.ident _self record_rest_ident in + {field with record_rest_ident} + +let object_rest_param : object_rest_param fn = + fun _self {object_rest_fields; object_rest_rest} -> + let object_rest_fields = list record_rest_field _self object_rest_fields in + let object_rest_rest = _self.ident _self object_rest_rest in + {object_rest_fields; object_rest_rest} + +let param : param fn = + fun _self -> function + | Ident_param id -> + let id = _self.ident _self id in + Ident_param id + | Object_rest_param rest -> + let rest = object_rest_param _self rest in + Object_rest_param rest + let expression_desc : expression_desc fn = fun _self -> function | Length (_x0, _x1) -> @@ -163,7 +183,7 @@ let expression_desc : expression_desc fn = let _x0 = _self.vident _self _x0 in Var _x0 | Fun ({params; body} as fun_) -> - let params = list _self.ident _self params in + let params = list param _self params in let body = _self.block _self body in Fun {fun_ with params; body} | Str _ as v -> v @@ -194,6 +214,9 @@ let expression_desc : expression_desc fn = | Spread _x0 -> let _x0 = _self.expression _self _x0 in Spread _x0 + | Record_rest (_x0, _x1) -> + let _x1 = _self.expression _self _x1 in + Record_rest (_x0, _x1) let for_ident_expression : for_ident_expression fn = fun _self arg -> _self.expression _self arg diff --git a/compiler/core/lam_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..629a4ca759a 100644 --- a/compiler/ext/warnings.ml +++ b/compiler/ext/warnings.ml @@ -75,6 +75,7 @@ type t = (string * top_level_unit_help) option (* 109 *) | Bs_todo of string option (* 110 *) | Bs_private_record_mutation of string (* 111 *) + | Bs_record_rest_empty (* 112 *) (* If you remove a warning, leave a hole in the numbering. NEVER change the numbers of existing warnings. @@ -128,8 +129,9 @@ let number = function | Bs_toplevel_expression_unit _ -> 109 | Bs_todo _ -> 110 | Bs_private_record_mutation _ -> 111 + | Bs_record_rest_empty -> 112 -let last_warning_number = 111 +let last_warning_number = 112 let letter_all = let rec loop i = if i = 0 then [] else i :: loop (i - 1) in @@ -448,6 +450,9 @@ let message = function `%s->ignore`" help_text help_text | _ -> "") + | Bs_record_rest_empty -> + "All fields of the rest type are already present in the explicit pattern. \ + The rest record will always be empty." | Bs_todo maybe_text -> (match maybe_text with | None -> "Todo found." @@ -569,6 +574,7 @@ let descriptions = (109, "Toplevel expression has unit type"); (110, "Todo found"); (111, "Mutation of private record field"); + (112, "Record rest pattern will always be empty"); ] let help_warnings () = diff --git a/compiler/ext/warnings.mli b/compiler/ext/warnings.mli index 46cba811ad7..e7be69baf32 100644 --- a/compiler/ext/warnings.mli +++ b/compiler/ext/warnings.mli @@ -68,6 +68,7 @@ type t = (string * top_level_unit_help) option (* 109 *) | Bs_todo of string option (* 110 *) | Bs_private_record_mutation of string (* 111 *) + | Bs_record_rest_empty (* 112 *) val parse_options : bool -> string -> unit diff --git a/compiler/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..080b42b31b0 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -93,6 +93,26 @@ let for_await_of_attr_name = "_res.for_await_of" let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} +let record_rest_attr_name = "res.record_rest" + +let record_rest_of_pattern (rest : Pt.pattern) = + match rest.Pt.ppat_desc with + | Pt.Ppat_constraint ({ppat_desc = Pt.Ppat_var rest_name; _}, rest_type) -> + Some {Pt.rest_loc = rest.ppat_loc; rest_name; rest_type = Some rest_type} + | Pt.Ppat_var rest_name -> + Some {Pt.rest_loc = rest.ppat_loc; rest_name; rest_type = None} + | _ -> None + +let get_record_rest_attr attrs_ = + let rec remove_record_rest_attr acc = function + | ({Location.txt = attr_name; _}, Pt.PPat (rest, None)) :: attrs + when attr_name = record_rest_attr_name -> + (record_rest_of_pattern rest, List.rev_append acc attrs) + | attr :: attrs -> remove_record_rest_attr (attr :: acc) attrs + | [] -> (None, List.rev acc) + in + remove_record_rest_attr [] attrs_ + module T = struct (* Type expressions for the core language *) @@ -656,7 +676,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..1b05477b169 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -87,6 +87,19 @@ let for_await_of_attr_name = "_res.for_await_of" let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} +let record_rest_attr_name = "res.record_rest" + +let add_record_rest_attr ~rest attrs = + (Location.mknoloc record_rest_attr_name, Pt.PPat (rest, None)) :: attrs + +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 +614,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..047a71b2f0d 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -158,13 +158,13 @@ let all_coherent column = _ ) -> false) | Tpat_tuple l1, Tpat_tuple l2 -> List.length l1 = List.length l2 - | ( Tpat_record ((_, lbl1, _, _) :: _, _), - Tpat_record ((_, lbl2, _, _) :: _, _) ) -> + | ( Tpat_record ((_, lbl1, _, _) :: _, _, _), + Tpat_record ((_, lbl2, _, _) :: _, _, _) ) -> Array.length lbl1.lbl_all = Array.length lbl2.lbl_all | Tpat_any, _ | _, Tpat_any - | Tpat_record ([], _), Tpat_record (_, _) - | Tpat_record (_, _), Tpat_record ([], _) + | Tpat_record ([], _, _), Tpat_record (_, _, _) + | Tpat_record (_, _, _), Tpat_record ([], _, _) | Tpat_variant _, Tpat_variant _ | Tpat_array _, Tpat_array _ -> true @@ -301,7 +301,7 @@ module Compat = struct l1 = l2 && ocompat ~equal_cd op1 op2 | Tpat_constant c1, Tpat_constant c2 -> const_compare c1 c2 = 0 | Tpat_tuple ps, Tpat_tuple qs -> compats ~equal_cd ps qs - | Tpat_record (l1, _), Tpat_record (l2, _) -> + | Tpat_record (l1, _, _), Tpat_record (l2, _, _) -> let ps, qs = records_args l1 l2 in compats ~equal_cd ps qs | Tpat_array ps, Tpat_array qs -> @@ -399,7 +399,7 @@ let rec pretty_val ppf v = | _ -> fprintf ppf "@[<2>%s@ @[(%a)@]@]" name (pretty_vals ",") vs) | Tpat_variant (l, None, _) -> fprintf ppf "#%s" l | Tpat_variant (l, Some w, _) -> fprintf ppf "@[<2>#%s(%a)@]" l pretty_arg w - | Tpat_record (lvs, _) -> ( + | Tpat_record (lvs, _, _rest) -> ( let filtered_lvs = Ext_list.filter lvs (function | _, _, {pat_desc = Tpat_any}, _ -> false (* do not show lbl=_ *) @@ -496,7 +496,7 @@ let simple_match p1 p2 = let record_arg p = match p.pat_desc with | Tpat_any -> [] - | Tpat_record (args, _) -> args + | Tpat_record (args, _, _rest) -> args | _ -> fatal_error "Parmatch.as_record" (* Raise Not_found when pos is not present in arg *) @@ -569,14 +569,14 @@ let rec simple_match_args p1 p2 = | Tpat_construct (_, _, args) -> args | Tpat_variant (_, Some arg, _) -> [arg] | Tpat_tuple args -> args - | Tpat_record (args, _) -> extract_fields (record_arg p1) args + | Tpat_record (args, _, _rest) -> extract_fields (record_arg p1) args | Tpat_array args -> args | Tpat_any | Tpat_var _ -> ( match p1.pat_desc with | Tpat_construct (_, _, args) -> omega_list args | Tpat_variant (_, Some _, _) -> [omega] | Tpat_tuple args -> omega_list args - | Tpat_record (args, _) -> omega_list args + | Tpat_record (args, _, _rest) -> omega_list args | Tpat_array args -> omega_list args | _ -> []) | _ -> [] @@ -601,11 +601,12 @@ let rec normalize_pat q = q.pat_type q.pat_env | Tpat_array args -> make_pat (Tpat_array (omega_list args)) q.pat_type q.pat_env - | Tpat_record (largs, closed) -> + | Tpat_record (largs, closed, rest) -> make_pat (Tpat_record ( List.map (fun (lid, lbl, _, opt) -> (lid, lbl, omega, opt)) largs, - closed )) + closed, + rest )) q.pat_type q.pat_env | Tpat_or _ -> fatal_error "Parmatch.normalize_pat" @@ -623,7 +624,7 @@ let discr_pat q pss = acc_pat acc ((p1 :: ps) :: (p2 :: ps) :: pss) | ({pat_desc = Tpat_any | Tpat_var _} :: _) :: pss -> acc_pat acc pss | (({pat_desc = Tpat_tuple _} as p) :: _) :: _ -> normalize_pat p - | (({pat_desc = Tpat_record (largs, closed)} as p) :: _) :: pss -> + | (({pat_desc = Tpat_record (largs, closed, rest)} as p) :: _) :: pss -> let new_omegas = List.fold_right (fun (lid, lbl, _, opt) r -> @@ -634,7 +635,7 @@ let discr_pat q pss = largs (record_arg acc) in acc_pat - (make_pat (Tpat_record (new_omegas, closed)) p.pat_type p.pat_env) + (make_pat (Tpat_record (new_omegas, closed, rest)) p.pat_type p.pat_env) pss | _ -> acc in @@ -661,7 +662,7 @@ let do_set_args erase_mutable q r = | {pat_desc = Tpat_tuple omegas} -> let args, rest = read_args omegas r in make_pat (Tpat_tuple args) q.pat_type q.pat_env :: rest - | {pat_desc = Tpat_record (omegas, closed)} -> + | {pat_desc = Tpat_record (omegas, closed, pat_rest)} -> let args, rest = read_args omegas r in make_pat (Tpat_record @@ -676,7 +677,8 @@ let do_set_args erase_mutable q r = then (lid, lbl, omega, opt) else (lid, lbl, arg, opt)) omegas args, - closed )) + closed, + pat_rest )) q.pat_type q.pat_env :: rest | {pat_desc = Tpat_construct (lid, c, omegas)} -> @@ -967,7 +969,7 @@ let pats_of_type ?(always = false) env ty = (mknoloc (Longident.Lident "?pat_of_label?"), ld, omega, false)) labels in - [make_pat (Tpat_record (fields, Closed)) ty env] + [make_pat (Tpat_record (fields, Closed, None)) ty env] | _ -> [omega] with Not_found -> [omega]) | Ttuple tl -> [make_pat (Tpat_tuple (omegas (List.length tl))) ty env] @@ -1170,7 +1172,8 @@ let rec has_instance p = | Tpat_or (p1, p2, _) -> has_instance p1 || has_instance p2 | Tpat_construct (_, _, ps) | Tpat_tuple ps | Tpat_array ps -> has_instances ps - | Tpat_record (lps, _) -> has_instances (List.map (fun (_, _, x, _) -> x) lps) + | Tpat_record (lps, _, _rest) -> + has_instances (List.map (fun (_, _, x, _) -> x) lps) and has_instances = function | [] -> true @@ -1379,7 +1382,7 @@ let print_pat pat = | Tpat_tuple list -> Printf.sprintf "(%s)" (String.concat "," (List.map string_of_pat list)) | Tpat_variant (_, _, _) -> "variant" - | Tpat_record (_, _) -> "record" + | Tpat_record (_, _, _) -> "record" | Tpat_array _ -> "array" in Printf.fprintf stderr "PAT[%s]\n%!" (string_of_pat pat) @@ -1784,7 +1787,7 @@ let rec le_pat p q = | Tpat_variant (l1, None, _r1), Tpat_variant (l2, None, _) -> l1 = l2 | Tpat_variant (_, _, _), Tpat_variant (_, _, _) -> false | Tpat_tuple ps, Tpat_tuple qs -> le_pats ps qs - | Tpat_record (l1, _), Tpat_record (l2, _) -> + | Tpat_record (l1, _, _), Tpat_record (l2, _, _) -> let ps, qs = records_args l1 l2 in le_pats ps qs | Tpat_array ps, Tpat_array qs -> Ext_list.same_length ps qs && le_pats ps qs @@ -1831,9 +1834,9 @@ let rec lub p q = let r = lub p1 p2 in make_pat (Tpat_variant (l1, Some r, row)) p.pat_type p.pat_env | Tpat_variant (l1, None, _row), Tpat_variant (l2, None, _) when l1 = l2 -> p - | Tpat_record (l1, closed), Tpat_record (l2, _) -> + | Tpat_record (l1, closed, rest), Tpat_record (l2, _, _) -> let rs = record_lubs l1 l2 in - make_pat (Tpat_record (rs, closed)) p.pat_type p.pat_env + make_pat (Tpat_record (rs, closed, rest)) p.pat_type p.pat_env | Tpat_array ps, Tpat_array qs when List.length ps = List.length qs -> let rs = lubs ps qs in make_pat (Tpat_array rs) p.pat_type p.pat_env @@ -1992,7 +1995,7 @@ module Conv = struct | Tpat_variant (label, p_opt, _row_desc) -> let arg = Misc.may_map loop p_opt in mkpat (Ppat_variant (label, arg)) - | Tpat_record (subpatterns, _closed_flag) -> + | Tpat_record (subpatterns, _closed_flag, _rest) -> let fields = List.map (fun (_, lbl, p, optional) -> @@ -2001,7 +2004,7 @@ module Conv = struct {lid = mknoloc (Longident.Lident id); x = loop p; opt = optional}) subpatterns in - mkpat (Ppat_record (fields, Open)) + mkpat (Ppat_record (fields, Open, None)) | Tpat_array lst -> mkpat (Ppat_array (List.map loop lst)) in let ps = loop typed in @@ -2153,7 +2156,7 @@ let rec collect_paths_from_pat r p = | Tpat_array ps | Tpat_construct (_, {cstr_tag = Cstr_extension _}, ps) -> List.fold_left collect_paths_from_pat r ps - | Tpat_record (lps, _) -> + | Tpat_record (lps, _, _rest) -> List.fold_left (fun r (_, _, p, _) -> collect_paths_from_pat r p) r lps | Tpat_variant (_, Some p, _) | Tpat_alias (p, _, _) -> collect_paths_from_pat r p @@ -2284,7 +2287,7 @@ let inactive ~partial pat = | Tpat_tuple ps | Tpat_construct (_, _, ps) -> List.for_all (fun p -> loop p) ps | Tpat_alias (p, _, _) | Tpat_variant (_, Some p, _) -> loop p - | Tpat_record (ldps, _) -> + | Tpat_record (ldps, _, _rest) -> List.for_all (fun (_, lbl, p, _) -> lbl.lbl_mut = Immutable && loop p) ldps @@ -2432,12 +2435,12 @@ let filter_all = a pattern *) let discr_head pat = match pat.pat_desc with - | Tpat_record (lbls, closed) -> + | Tpat_record (lbls, closed, rest) -> (* a partial record pattern { f1 = p1; f2 = p2; _ } needs to be expanded, otherwise matching against this head would drop the pattern arguments for non-mentioned fields *) let lbls = all_record_args lbls in - normalize_pat {pat with pat_desc = Tpat_record (lbls, closed)} + normalize_pat {pat with pat_desc = Tpat_record (lbls, closed, rest)} | _ -> normalize_pat pat in diff --git a/compiler/ml/parsetree.ml b/compiler/ml/parsetree.ml index 29207d0150b..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..57a56b052a7 100644 --- a/compiler/ml/printtyped.ml +++ b/compiler/ml/printtyped.ml @@ -231,7 +231,7 @@ and pattern i ppf x = | Tpat_variant (l, po, _) -> line i ppf "Tpat_variant \"%s\"\n" l; option i pattern ppf po - | Tpat_record (l, _c) -> + | Tpat_record (l, _c, _rest) -> line i ppf "Tpat_record\n"; list i longident_x_pattern ppf l | Tpat_array l -> diff --git a/compiler/ml/rec_check.ml b/compiler/ml/rec_check.ml index 61f55114e97..bd3cddf1b1e 100644 --- a/compiler/ml/rec_check.ml +++ b/compiler/ml/rec_check.ml @@ -156,7 +156,7 @@ let rec pattern_variables : Typedtree.pattern -> Ident.t list = | Tpat_construct (_, _, pats) -> List.concat (List.map pattern_variables pats) | Tpat_variant (_, Some pat, _) -> pattern_variables pat | Tpat_variant (_, None, _) -> [] - | Tpat_record (fields, _) -> + | Tpat_record (fields, _, _rest) -> List.concat (List.map (fun (_, _, p, _) -> pattern_variables p) fields) | Tpat_array pats -> List.concat (List.map pattern_variables pats) | Tpat_or (l, r, _) -> pattern_variables l @ pattern_variables r @@ -438,7 +438,7 @@ and is_destructuring_pattern : Typedtree.pattern -> bool = | Tpat_tuple _ -> true | Tpat_construct (_, _, _) -> true | Tpat_variant _ -> true - | Tpat_record (_, _) -> true + | Tpat_record (_, _, _) -> true | Tpat_array _ -> true | Tpat_or (l, r, _) -> is_destructuring_pattern l || is_destructuring_pattern r diff --git a/compiler/ml/tast_iterator.ml b/compiler/ml/tast_iterator.ml index 86f77420bd2..077837d2af6 100644 --- a/compiler/ml/tast_iterator.ml +++ b/compiler/ml/tast_iterator.ml @@ -129,7 +129,7 @@ let pat sub {pat_extra; pat_desc; pat_env; _} = | Tpat_tuple l -> List.iter (sub.pat sub) l | Tpat_construct (_, _, l) -> List.iter (sub.pat sub) l | Tpat_variant (_, po, _) -> Option.iter (sub.pat sub) po - | Tpat_record (l, _) -> List.iter (fun (_, _, i, _) -> sub.pat sub i) l + | Tpat_record (l, _, _rest) -> List.iter (fun (_, _, i, _) -> sub.pat sub i) l | Tpat_array l -> List.iter (sub.pat sub) l | Tpat_or (p1, p2, _) -> sub.pat sub p1; diff --git a/compiler/ml/tast_mapper.ml b/compiler/ml/tast_mapper.ml index 1d0e49efd35..fd2e57baee5 100644 --- a/compiler/ml/tast_mapper.ml +++ b/compiler/ml/tast_mapper.ml @@ -171,8 +171,8 @@ let pat sub x = | Tpat_construct (loc, cd, l) -> Tpat_construct (loc, cd, List.map (sub.pat sub) l) | Tpat_variant (l, po, rd) -> Tpat_variant (l, opt (sub.pat sub) po, rd) - | Tpat_record (l, closed) -> - Tpat_record (List.map (tuple4 id id (sub.pat sub) id) l, closed) + | Tpat_record (l, closed, rest) -> + Tpat_record (List.map (tuple4 id id (sub.pat sub) id) l, closed, rest) | Tpat_array l -> Tpat_array (List.map (sub.pat sub) l) | Tpat_or (p1, p2, rd) -> Tpat_or (sub.pat sub p1, sub.pat sub p2, rd) | Tpat_alias (p, id, s) -> Tpat_alias (sub.pat sub p, id, s) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 37bbf81b60a..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..085735b3b2a --- /dev/null +++ b/compiler/ml/typecore_record_rest.ml @@ -0,0 +1,318 @@ +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 has_mutable_field fields = + Ext_list.exists fields (fun (field : label_declaration) -> + field.ld_mutable = Mutable) + +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 has_mutable_field fields 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 = + match Ast_untagged_variants.process_tag_name attrs with + | Some s -> s + | None -> "TAG" + in + if List.mem tag_name explicit_runtime_labels then explicit_runtime_labels + else tag_name :: explicit_runtime_labels + | _ -> explicit_runtime_labels + +(* 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 = + 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 _ -> rest_decl + | _ -> raise_error rest_type_lid.loc env (Not_record rest_type_lid.txt)) + | None -> raise_error rest_type_lid.loc env (Not_record rest_type_lid.txt) + in + let explicit_fields = + List.map (fun (_, label, _, _) -> label.lbl_name) lbl_pat_list + in + let explicit_runtime_labels = + List.map + (fun (_, label, _, _) -> runtime_label_description_name label) + lbl_pat_list + in + let explicit_optional_fields = + List.filter_map + (fun (_, label, _, optional) -> + if optional then Some label.lbl_name else None) + lbl_pat_list + in + let rest_labels = + match rest_decl.type_kind with + | Type_record (labels, _) -> labels + | _ -> assert false + in + let rest_field_names = + List.map (fun label -> Ident.name label.ld_id) rest_labels + in + let source_fields, source_repr = + resolve_source_record ~env ~unify_pat_types ~loc ~record_ty ~rest_type_lid + ~rest_type_expr ~rest_decl + in + let not_optional = + List.filter + (fun rest_field -> + List.mem rest_field explicit_fields + && not (List.mem rest_field explicit_optional_fields)) + rest_field_names + in + if not_optional <> [] then + raise_error rest.rest_loc env + (Field_not_optional (not_optional, rest_type_lid.txt)); + let source_field_names = + List.map (fun field -> field.source_name) source_fields + in + let missing = + List.filter + (fun source_field -> + (not (List.mem source_field explicit_fields)) + && not (List.mem source_field rest_field_names)) + source_field_names + in + if missing <> [] then + raise_error rest.rest_loc env (Field_missing (missing, rest_type_lid.txt)); + List.iter + (fun (rest_label : label_declaration) -> + let rest_field = Ident.name rest_label.ld_id in + let rest_runtime_name = runtime_label_declaration_name rest_label in + match + Ext_list.find_first source_fields (fun field -> + field.source_name = rest_field) + with + | None -> + raise_error rest_type_lid.loc env + (Extra_field (rest_field, rest_type_lid.txt)) + | Some source_field -> + if source_field.source_runtime_name <> rest_runtime_name then + raise_error rest_type_lid.loc env + (Field_runtime_name_mismatch + { + field = rest_field; + rest_type = rest_type_lid.txt; + source_runtime_name = source_field.source_runtime_name; + rest_runtime_name; + }); + unify_pat_types rest_type_lid.loc env rest_label.ld_type + source_field.source_type) + rest_labels; + if + rest_field_names <> [] + && List.for_all + (fun field -> List.mem field explicit_fields) + rest_field_names + then Location.prerr_warning rest.rest_loc Warnings.Bs_record_rest_empty; + let rest_ident = enter_variable rest.rest_loc rest.rest_name rest_type_expr in + { + Typedtree.rest_ident; + rest_name = rest.rest_name; + rest_type = rest_type_expr; + excluded_runtime_labels = + runtime_excluded_labels ~explicit_runtime_labels source_repr; + } + +let report_error ppf = function + | Invalid_type -> + fprintf ppf "Record rest pattern must have the form: ...Type.t as name" + | Requires_type_annotation name -> + fprintf ppf + "Record rest pattern `...%s` requires a type annotation. Use `...Type.t \ + as %s`." + name name + | Not_record lid -> + fprintf ppf + "Type %a is not a record type and cannot be used as a record rest \ + pattern." + Printtyp.longident lid + | Field_not_optional (fields, lid) -> ( + let field_list = + fields |> List.map (fun field -> "\n- " ^ field) |> String.concat "" + in + match fields with + | [field] -> + fprintf ppf + "The following field appears in both the explicit pattern and the rest \ + type `%a`:%s\n\n\ + Mark it as optional (`?%s`) in the explicit pattern." + Printtyp.longident lid field_list field + | _ -> + fprintf ppf + "The following fields appear in both the explicit pattern and the rest \ + type `%a`:%s\n\n\ + Mark them as optional (e.g. `?fieldName`) in the explicit pattern." + Printtyp.longident lid field_list) + | Field_missing (fields, lid) -> ( + let field_list = + fields |> List.map (fun field -> "\n- " ^ field) |> String.concat "" + in + match fields with + | [_] -> + fprintf ppf + "The following field is not part of the rest type `%a`:%s\n\n\ + List this field in the record pattern before the spread so it's not \ + present in the rest record." + Printtyp.longident lid field_list + | _ -> + fprintf ppf + "The following fields are not part of the rest type `%a`:%s\n\n\ + List these fields in the record pattern before the spread so they're \ + not present in the rest record." + Printtyp.longident lid field_list) + | Extra_field (field, lid) -> + fprintf ppf + "Field `%s` in the rest type `%a` does not exist in the source record \ + type." + field Printtyp.longident lid + | Field_runtime_name_mismatch + {field; rest_type; source_runtime_name; rest_runtime_name} -> + fprintf ppf + "Field `%s` in the rest type `%a` has runtime representation `%s`, but \ + in the source record type it is `%s`. Runtime representations must \ + match." + field Printtyp.longident rest_type rest_runtime_name source_runtime_name + | 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..aef9ee4959a 100644 --- a/compiler/syntax/src/res_comments_table.ml +++ b/compiler/syntax/src/res_comments_table.ml @@ -2135,7 +2135,7 @@ and walk_pattern pat t comments = | Ppat_variant (_label, None) -> () | Ppat_variant (_label, Some pat) -> walk_pattern pat t comments | Ppat_type _ -> () - | Ppat_record (record_rows, _) -> + | Ppat_record (record_rows, _, _rest) -> walk_list (Ext_list.map record_rows (fun {lid; x = p} -> PatternRecordRow (lid, p))) t comments diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index 2d3eabd3944..93a340af8fb 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,51 @@ and parse_record_pattern_row_field ~attrs p = and parse_record_pattern_row p = let attrs = parse_attributes p in match p.Parser.token with - | DotDotDot -> + | DotDotDot -> ( Parser.next p; - Some (true, PatField (parse_record_pattern_row_field ~attrs p)) + let start_pos = p.Parser.start_pos in + 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 loc; + 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 +1606,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 +1621,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..a1c1c631667 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,21 @@ and print_pattern ~state (p : Parsetree.pattern) cmt_tbl = Doc.soft_line; Doc.rbrace; ] - | Ppat_record ([], Open) -> + | Ppat_record ([], Open, None) -> Doc.concat [Doc.lbrace; Doc.text "_"; Doc.rbrace] - | Ppat_record (rows, open_flag) -> + | Ppat_record (rows, open_flag, rest) -> + let print_rest_pattern rest_pat = + match rest_pat.Parsetree.rest_type with + | Some typ -> + Doc.concat + [ + Doc.text "..."; + print_typ_expr ~state typ cmt_tbl; + Doc.text " as "; + Doc.text rest_pat.rest_name.txt; + ] + | None -> Doc.concat [Doc.text "..."; Doc.text rest_pat.rest_name.txt] + in Doc.group (Doc.concat [ @@ -2820,9 +2832,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..71ff64168d9 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, empty-rest warning, module destructure rejection, and singular/plural missing and overlap 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/src/RecordRest.res b/tests/analysis_tests/tests/src/RecordRest.res new file mode 100644 index 00000000000..a0e2a5373cc --- /dev/null +++ b/tests/analysis_tests/tests/src/RecordRest.res @@ -0,0 +1,17 @@ +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 {name: _, ...SubConfig.t as localRest} = {name: "v", version: "1"} +// ^ast + +//^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..6d7cadcec09 --- /dev/null +++ b/tests/analysis_tests/tests/src/expected/RecordRest.res.txt @@ -0,0 +1,77 @@ +Definition src/RecordRest.res 8:4 +{ + "range": { + "end": { "character": 36, "line": 7 }, + "start": { "character": 32, "line": 7 } + }, + "uri": "file:///RecordRest.res" +} + +Dump AST src/RecordRest.res 12: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)) + ) +) + +Inlay Hint src/RecordRest.res 1:34 +[ + { + "kind": 1, + "label": ": SubConfig.t", + "paddingLeft": true, + "paddingRight": false, + "position": { "character": 41, "line": 12 } + }, + { + "kind": 1, + "label": ": config => string", + "paddingLeft": true, + "paddingRight": false, + "position": { "character": 14, "line": 5 } + } +] + +Highlight src/RecordRest.res +structure items:4 diagnostics:0 +Lident: config 0:5 Type +Lident: name 0:15 Property +Lident: string 0:21 Type +Lident: version 0:29 Property +Lident: string 0:38 Type +Lident: SubConfig 1:7 Namespace +Lident: t 2:7 Type +Lident: version 2:12 Property +Lident: string 2:21 Type +Variable: getVersion [5:4->5:14] +Variable: config [5:18->5:24] +Lident: config 5:26 Type +Lident: config 6:9 Variable +Lident: name 7:5 Property +Variable: rest [7:32->7:36] +Ldot: SubConfig 7:17 Namespace +Lident: t 7:27 Type +Lident: version 8:9 Property +Lident: rest 8:4 Variable +Lident: name 12:5 Property +Variable: localRest [12:32->12:41] +Ldot: SubConfig 12:17 Namespace +Lident: t 12:27 Type +Lident: name 12:46 Property +Lident: version 12:57 Property + diff --git a/tests/build_tests/super_errors/expected/record_rest_empty_warning.res.expected b/tests/build_tests/super_errors/expected/record_rest_empty_warning.res.expected new file mode 100644 index 00000000000..f3343bc01d8 --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_rest_empty_warning.res.expected @@ -0,0 +1,10 @@ + + Warning number 112 + /.../fixtures/record_rest_empty_warning.res:3:16-26 + + 1 │ type source = {a: int, b?: string} + 2 │ type sub = {b?: string} + 3 │ let {a, ?b, ...sub as rest} = ({a: 1}: source) + 4 │ + + All fields of the rest type are already present in the explicit pattern. The rest record will always be empty. diff --git a/tests/build_tests/super_errors/expected/record_rest_extra_field.res.expected b/tests/build_tests/super_errors/expected/record_rest_extra_field.res.expected new file mode 100644 index 00000000000..5250f826e70 --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_rest_extra_field.res.expected @@ -0,0 +1,10 @@ + + We've found a bug for you! + /.../fixtures/record_rest_extra_field.res:3:12-14 + + 1 │ type source = {a: int, x: int} + 2 │ type sub = {a: int, b: string} + 3 │ let {x, ...sub as rest} = ({a: 1, x: 2}: source) + 4 │ + + Field `b` in the rest type `sub` does not exist in the source record type. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/record_rest_field_missing.res.expected b/tests/build_tests/super_errors/expected/record_rest_field_missing.res.expected new file mode 100644 index 00000000000..aafee7f85e0 --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_rest_field_missing.res.expected @@ -0,0 +1,14 @@ + + We've found a bug for you! + /.../fixtures/record_rest_field_missing.res:3:12-22 + + 1 │ type source = {a: int, b: string, c: bool, d: float} + 2 │ type sub = {b: string} + 3 │ let {a, ...sub as rest} = ({a: 1, b: "x", c: true, d: 1.0}: source) + 4 │ + + The following fields are not part of the rest type `sub`: +- c +- d + +List these fields in the record pattern before the spread so they're not present in the rest record. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/record_rest_field_missing_singular.res.expected b/tests/build_tests/super_errors/expected/record_rest_field_missing_singular.res.expected new file mode 100644 index 00000000000..8531afb9f01 --- /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:12-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..458da763631 --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_rest_field_not_optional.res.expected @@ -0,0 +1,13 @@ + + We've found a bug for you! + /.../fixtures/record_rest_field_not_optional.res:3:12-22 + + 1 │ type source = {a?: int, b?: string, c: bool} + 2 │ type sub = {a?: int, b?: string} + 3 │ let {a, ...sub as rest}: source = {c: true} + 4 │ + + The following field appears in both the explicit pattern and the rest type `sub`: +- a + +Mark it as optional (`?a`) in the explicit pattern. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/record_rest_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..573f87e46b7 --- /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:15-25 + + 1 │ type source = {a?: int, b?: string, c: bool} + 2 │ type sub = {a?: int, b?: string} + 3 │ let {a, b, ...sub as rest}: source = {c: true} + 4 │ + + The following fields appear in both the explicit pattern and the rest type `sub`: +- a +- b + +Mark them as optional (e.g. `?fieldName`) in the explicit pattern. \ No newline at end of file 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..98047fce9cd --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_rest_invalid_type.res.expected @@ -0,0 +1,9 @@ + + We've found a bug for you! + /.../fixtures/record_rest_invalid_type.res:2:12-21 + + 1 │ type source = {a: int, b: string} + 2 │ let {a, ...'a as rest} = ({a: 1, b: "x"}: source) + 3 │ + + Record rest pattern must have the form: ...Type.t as name \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/record_rest_module_destructure.res.expected b/tests/build_tests/super_errors/expected/record_rest_module_destructure.res.expected new file mode 100644 index 00000000000..185c334b1f0 --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_rest_module_destructure.res.expected @@ -0,0 +1,10 @@ + + We've found a bug for you! + /.../fixtures/record_rest_module_destructure.res:3:15-34 + + 1 │ module A = Belt.Array + 2 │ + 3 │ let {push, ...arrayMethods as rest} = module(A) + 4 │ + + Record rest patterns are not supported when destructuring modules. Bind the module fields explicitly. \ No newline at end of file diff --git a/tests/build_tests/super_errors/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_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..49483d2c99e --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_rest_requires_type_annotation.res.expected @@ -0,0 +1,9 @@ + + We've found a bug for you! + /.../fixtures/record_rest_requires_type_annotation.res:2:12-18 + + 1 │ type source = {a: int, b: string} + 2 │ let {a, ...theRest} = ({a: 1, b: "x"}: source) + 3 │ + + Record rest pattern `...theRest` requires a type annotation. Use `...Type.t as theRest`. \ No newline at end of file diff --git a/tests/build_tests/super_errors/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_empty_warning.res b/tests/build_tests/super_errors/fixtures/record_rest_empty_warning.res new file mode 100644 index 00000000000..817b139276c --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/record_rest_empty_warning.res @@ -0,0 +1,3 @@ +type source = {a: int, b?: string} +type sub = {b?: string} +let {a, ?b, ...sub as rest} = ({a: 1}: source) diff --git a/tests/build_tests/super_errors/fixtures/record_rest_extra_field.res b/tests/build_tests/super_errors/fixtures/record_rest_extra_field.res new file mode 100644 index 00000000000..d7c8f59eb92 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/record_rest_extra_field.res @@ -0,0 +1,3 @@ +type source = {a: int, x: int} +type sub = {a: int, b: string} +let {x, ...sub as rest} = ({a: 1, x: 2}: source) diff --git a/tests/build_tests/super_errors/fixtures/record_rest_field_missing.res b/tests/build_tests/super_errors/fixtures/record_rest_field_missing.res new file mode 100644 index 00000000000..8a7fadc14ce --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/record_rest_field_missing.res @@ -0,0 +1,3 @@ +type source = {a: int, b: string, c: bool, d: float} +type sub = {b: string} +let {a, ...sub as rest} = ({a: 1, b: "x", c: true, d: 1.0}: source) diff --git a/tests/build_tests/super_errors/fixtures/record_rest_field_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..d5bffdb282f --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/record_rest_field_not_optional.res @@ -0,0 +1,3 @@ +type source = {a?: int, b?: string, c: bool} +type sub = {a?: int, b?: string} +let {a, ...sub as rest}: source = {c: true} diff --git a/tests/build_tests/super_errors/fixtures/record_rest_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..a52ca15b596 --- /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, c: bool} +type sub = {a?: int, b?: string} +let {a, b, ...sub as rest}: source = {c: true} 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_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_js_analyzer_tests.ml b/tests/ounit_tests/ounit_js_analyzer_tests.ml index 6a595cfd1a0..8e8ea239e6b 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 = [Ident_param 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,145 @@ 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 field = Ident.create "name" in + let rest = Ident.create "rest" in + let folder = + { + Js_record_fold.super with + ident = (fun _ names ident -> Ident.name ident :: names); + } + in + let names = + Js_record_fold.param folder [] + (Object_rest_param + { + object_rest_fields = + [ + { + record_rest_label = "name"; + record_rest_ident = Some field; + }; + ]; + object_rest_rest = rest; + }) + in + OUnit.assert_equal ["rest"; "name"] names; + OUnit.assert_equal ["name"] + (Js_record_fold.param folder [] (Ident_param field)) ); + ( __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 = + [ + Object_rest_param + { + object_rest_fields = + [ + { + record_rest_label = "name"; + record_rest_ident = Some ignored; + }; + ]; + object_rest_rest = rest; + }; + ]; + body = + [ + { + statement_desc = + Return {expression_desc = Var (Id returned); _}; + _; + }; + ]; + _; + } -> + OUnit.assert_equal "__unused0" (Ident.name ignored); + OUnit.assert_equal "rest" (Ident.name rest); + 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/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..dce00643948 --- /dev/null +++ b/tests/syntax_tests/data/parsing/errors/other/expected/record_rest_duplicate.res.txt @@ -0,0 +1,11 @@ + + Syntax error! + syntax_tests/data/parsing/errors/other/record_rest_duplicate.res:1:9-51 + + 1 │ let {...Config.t as first, ...Config.t as second} = myRecord + 2 │ + + Record patterns can only have one `...` rest clause. +Use a single `...typeName as bindingName` clause to capture the remaining fields. + +let { ...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..93a3f65fa05 100644 --- a/tests/syntax_tests/data/parsing/errors/other/expected/spread.res.txt +++ b/tests/syntax_tests/data/parsing/errors/other/expected/spread.res.txt @@ -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:9-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/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..16c1bb54f33 --- /dev/null +++ b/tests/tests/src/record_rest_test.mjs @@ -0,0 +1,392 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + +import * as Mocha from "mocha"; +import * as Test_utils from "./test_utils.mjs"; + +let SubConfig = {}; + +function describeConfig(c) { + let {name, ...rest} = c; + return [ + name, + rest + ]; +} + +function getNameAndSubConfig({name, ...subConfig}) { + return [ + name, + subConfig + ]; +} + +function getAliasedRest({name: __unused0, ...rest}) { + return rest; +} + +function getNamespacedRest({name: __unused0, ...rest}) { + return rest; +} + +function getRenamedRest({"user-name": __unused0, ...rest}) { + return rest; +} + +function getRenamedNameAndRest({"user-name": __rest_field0, ...rest}) { + return [ + __rest_field0, + rest + ]; +} + +function getName(param) { + return param.name; +} + +function getWholeConfig({...rest}) { + return rest; +} + +function makeConfig() { + return { + name: "call", + version: "4.5", + debug: true + }; +} + +function getCallResultRest() { + return (({name: __unused0, ...__rest}) => __rest)({ + name: "call", + version: "4.5", + debug: true + }); +} + +function getNameRestAndOriginalVersion(original) { + let {name, ...rest} = original; + return [ + name, + rest, + original.version + ]; +} + +function extractClassName({className: __unused0, ...rest}) { + return rest; +} + +function getValue({id: __unused0, ...rest}) { + return rest; +} + +function getTupleRest(param) { + return (({name: __unused0, ...__rest}) => __rest)(param[0]); +} + +function getWrappedRest(wrapped) { + return (({name: __unused0, ...__rest}) => __rest)(wrapped._0); +} + +function getInlineWrappedRest(wrapped) { + return (({TAG: __unused0, name: __unused1, ...__rest}) => __rest)(wrapped); +} + +function getRenamedInlineWrappedRest(wrapped) { + return (({TAG: __unused0, "user-name": __unused1, ...__rest}) => __rest)(wrapped); +} + +function getCustomTaggedInlineWrappedRest(wrapped) { + return (({kind: __unused0, name: __unused1, ...__rest}) => __rest)(wrapped); +} + +function getDashedTaggedInlineWrappedRest(wrapped) { + return (({"custom-tag": __unused0, name: __unused1, ...__rest}) => __rest)(wrapped); +} + +Mocha.describe("Record_rest_test", () => { + Mocha.test("let binding captures record rest value", () => { + let {name: __unused0, ...rest} = { + name: "test", + version: "1.0", + debug: true + }; + Test_utils.eq("File \"record_rest_test.res\", line 150, characters 7-14", "test", "test"); + Test_utils.eq("File \"record_rest_test.res\", line 151, 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 156, 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 163, 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 168, 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 176, 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 188, 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 193, 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 201, 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 209, 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 217, characters 7-14", whole, { + name: "wholeAlias", + version: "3.6", + debug: true + }); + Test_utils.eq("File \"record_rest_test.res\", line 218, 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 224, 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 229, characters 7-14", "1", "1"); + Test_utils.eq("File \"record_rest_test.res\", line 230, characters 7-14", intRest, { + value: 42 + }); + Test_utils.eq("File \"record_rest_test.res\", line 231, 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 236, 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 243, 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 248, 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 256, 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 261, 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 269, 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 274, 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 282, 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 289, 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 299, 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 306, 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 316, 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 323, characters 6-13", getDashedTaggedInlineWrappedRest({ + "custom-tag": "DashedInlineMirror", + name: "dashedInlineMirror", + version: "12.0", + debug: false + }), { + version: "12.0", + debug: false + }); + }); +}); + +export { + SubConfig, + describeConfig, + getNameAndSubConfig, + 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..d444f09d71d --- /dev/null +++ b/tests/tests/src/record_rest_test.res @@ -0,0 +1,330 @@ +open Mocha +open Test_utils + +type config = { + name: string, + version: string, + debug: bool, +} + +type subConfig = { + version: string, + debug: bool, +} + +module SubConfig = { + type t = { + version: string, + debug: bool, + } +} + +type aliasedSubConfig = subConfig + +type renamedConfig = { + @as("user-name") + name: string, + version: string, + debug: bool, +} + +let describeConfig = (c: config) => + switch c { + | {name, ...subConfig as rest} => (name, rest) + } + +let getNameAndSubConfig = ({name, ...subConfig as subConfig}: config) => (name, subConfig) + +let getAliasedRest = ({name: _, ...aliasedSubConfig as rest}: config) => rest +let getNamespacedRest = ({name: _, ...SubConfig.t as rest}: config) => rest + +let getRenamedRest = ({name: _, ...subConfig as rest}: renamedConfig) => rest +let getRenamedNameAndRest = ({name, ...subConfig as rest}: renamedConfig) => (name, rest) + +let getName = ({name, ...subConfig 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: _, ...subConfig as rest} = makeConfig() + rest +} + +let getNameRestAndOriginalVersion = ({name, ...subConfig 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, +} + +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: _, ...subConfig as rest}, _): (config, int)) => rest + +let getWrappedRest = wrapped => + switch wrapped { + | Wrap({name: _, ...subConfig as rest}) + | Mirror({name: _, ...subConfig 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: _, ...subConfig as rest}) + | InlineMirror({name: _, ...subConfig as rest}) => rest + } + +type renamedInlineWrapped = + | RenamedInlineWrap({ + @as("user-name") + name: string, + version: string, + debug: bool, + }) + | RenamedInlineMirror({ + @as("user-name") + name: string, + version: string, + debug: bool, + }) + +let getRenamedInlineWrappedRest = wrapped => + switch wrapped { + | RenamedInlineWrap({name: _, ...subConfig as rest}) + | RenamedInlineMirror({name: _, ...subConfig as rest}) => rest + } + +@tag("kind") +type customTaggedInlineWrapped = + | CustomInlineWrap({name: string, version: string, debug: bool}) + | CustomInlineMirror({name: string, version: string, debug: bool}) + +let getCustomTaggedInlineWrappedRest = wrapped => + switch wrapped { + | CustomInlineWrap({name: _, ...subConfig as rest}) + | CustomInlineMirror({name: _, ...subConfig as rest}) => rest + } + +@tag("custom-tag") +type dashedTaggedInlineWrapped = + | DashedInlineWrap({name: string, version: string, debug: bool}) + | DashedInlineMirror({name: string, version: string, debug: bool}) + +let getDashedTaggedInlineWrappedRest = wrapped => + switch wrapped { + | DashedInlineWrap({name: _, ...subConfig as rest}) + | DashedInlineMirror({name: _, ...subConfig as rest}) => rest + } + +describe(__MODULE__, () => { + test("let binding captures record rest value", () => { + let {name, ...subConfig as rest} = ({name: "test", version: "1.0", debug: true}: config) + 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: _, ...SubConfig.t as rest} = ( + { + name: "namespaced-let", + version: "3.16", + debug: false, + }: config + ) + eq(__LOC__, rest, {version: "3.16", debug: false}) + }) + + test("record rest excludes fields renamed with @as", () => { + eq( + __LOC__, + 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}, + ) + }) +}) 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..75da4bbdf89 --- /dev/null +++ b/tests/tools_tests/src/expected/ZRecordRest.res.jsout @@ -0,0 +1,13 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE +'use strict'; + + +function extract({name, ...rest}) { + return [ + name, + rest + ]; +} + +exports.extract = extract; +/* No side effect */