Skip to content

Commit da71513

Browse files
tsnobiptsnobip
committed
check rest field types, fix matching & invalid field identifier
1 parent f835e3f commit da71513

File tree

8 files changed

+254
-113
lines changed

8 files changed

+254
-113
lines changed

‎compiler/core/lam_compile_primitive.ml‎

Lines changed: 16 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -606,10 +606,22 @@ let translate output_prefix loc (cxt : Lam_compile_context.t)
606606
| Precord_spread_new excluded -> (
607607
match args with
608608
| [e1] ->
609-
(* Generate: (({field1, field2, ...rest}) => rest)(source)
610-
This uses JS destructuring to cleanly extract the rest *)
611-
let excluded_str = String.concat ", " excluded in
612-
let code = Printf.sprintf "(({%s, ...__rest}) => __rest)" excluded_str in
609+
(* Generate: (({field1: __unused0, ...__rest}) => __rest)(source)
610+
This uses JS destructuring to cleanly extract the rest while
611+
safely handling quoted property names and the empty-exclusion case. *)
612+
let excluded_bindings =
613+
List.mapi
614+
(fun i field ->
615+
let field = Js_dump_property.property_key (Js_op.Lit field) in
616+
Printf.sprintf "%s: __unused%d" field i)
617+
excluded
618+
in
619+
let destructured =
620+
match excluded_bindings with
621+
| [] -> "...__rest"
622+
| _ -> String.concat ", " excluded_bindings ^ ", ...__rest"
623+
in
624+
let code = Printf.sprintf "(({%s}) => __rest)" destructured in
613625
E.call
614626
~info:{arity = Full; call_info = Call_na; call_transformed_jsx = false}
615627
(E.raw_js_code (Exp (Js_function {arity = 1; arrow = true})) code)

‎compiler/ml/matching.ml‎

Lines changed: 7 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -564,7 +564,13 @@ let simplify_cases args cls =
564564
| Tpat_any -> cl :: simplify rem
565565
| Tpat_alias (p, id, _) ->
566566
simplify ((p :: patl, bind Alias id arg action) :: rem)
567-
| Tpat_record ([], _, _rest) -> (omega :: patl, action) :: simplify rem
567+
| Tpat_record ([], _, rest) ->
568+
let action =
569+
match rest with
570+
| None -> action
571+
| Some rest -> bind_record_rest pat.pat_loc arg rest action
572+
in
573+
(omega :: patl, action) :: simplify rem
568574
| Tpat_record (lbls, closed, rest) ->
569575
let all_lbls = all_record_args lbls in
570576
let full_pat =

‎compiler/ml/typecore.ml‎

Lines changed: 115 additions & 83 deletions
Original file line numberDiff line numberDiff line change
@@ -1581,9 +1581,9 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp
15811581
let rest_path, rest_decl =
15821582
Typetexp.find_type !env rest_type_lid.loc rest_type_lid.txt
15831583
in
1584-
let rest_labels =
1585-
match rest_decl with
1586-
| {type_kind = Type_record (labels, _)} -> labels
1584+
let rest_decl =
1585+
match rest_decl.type_kind with
1586+
| Type_record _ -> instance_declaration rest_decl
15871587
| _ ->
15881588
raise
15891589
(Error
@@ -1595,6 +1595,77 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp
15951595
let explicit_fields =
15961596
List.map (fun (_, label, _, _) -> label.lbl_name) lbl_pat_list
15971597
in
1598+
let rest_type_args =
1599+
match rest_type_args_syntax with
1600+
| [] -> List.map (fun _ -> newvar ()) rest_decl.type_params
1601+
| args ->
1602+
let n_args = List.length args in
1603+
let n_params = List.length rest_decl.type_params in
1604+
if n_args <> n_params then
1605+
raise
1606+
(Typetexp.Error
1607+
( rest_type_lid.loc,
1608+
!env,
1609+
Typetexp.Type_arity_mismatch
1610+
(rest_type_lid.txt, n_params, n_args) ));
1611+
List.map
1612+
(fun sty ->
1613+
let cty, force =
1614+
Typetexp.transl_simple_type_delayed !env sty
1615+
in
1616+
pattern_force := force :: !pattern_force;
1617+
cty.ctyp_type)
1618+
args
1619+
in
1620+
let rest_type_expr =
1621+
newgenty (Tconstr (rest_path, rest_type_args, ref Mnil))
1622+
in
1623+
List.iter2
1624+
(fun param arg -> unify_pat_types rest_type_lid.loc !env param arg)
1625+
rest_decl.type_params rest_type_args;
1626+
let source_fields, source_repr =
1627+
match
1628+
try
1629+
let _, _, source_decl =
1630+
extract_concrete_typedecl !env record_ty
1631+
in
1632+
let source_decl = instance_declaration source_decl in
1633+
let source_type_args =
1634+
match expand_head !env record_ty with
1635+
| {desc = Tconstr (_, args, _)} -> args
1636+
| _ -> assert false
1637+
in
1638+
Some (source_decl, source_type_args)
1639+
with Not_found -> None
1640+
with
1641+
| Some (source_decl, source_type_args) -> (
1642+
List.iter2
1643+
(fun param arg -> unify_pat_types loc !env param arg)
1644+
source_decl.type_params source_type_args;
1645+
match source_decl.type_kind with
1646+
| Type_record (fields, repr) ->
1647+
( List.map
1648+
(fun (l : Types.label_declaration) ->
1649+
(Ident.name l.ld_id, l.ld_type))
1650+
fields,
1651+
repr )
1652+
| _ -> assert false)
1653+
| None -> (
1654+
unify_pat_types rest_type_lid.loc !env record_ty rest_type_expr;
1655+
match rest_decl.type_kind with
1656+
| Type_record (fields, repr) ->
1657+
( List.map
1658+
(fun (l : Types.label_declaration) ->
1659+
(Ident.name l.ld_id, l.ld_type))
1660+
fields,
1661+
repr )
1662+
| _ -> assert false)
1663+
in
1664+
let rest_labels =
1665+
match rest_decl.type_kind with
1666+
| Type_record (labels, _) -> labels
1667+
| _ -> assert false
1668+
in
15981669
(* Get explicit optional fields *)
15991670
let explicit_optional_fields =
16001671
List.filter_map
@@ -1603,20 +1674,17 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp
16031674
lbl_pat_list
16041675
in
16051676
let runtime_excluded_fields =
1606-
match lbl_pat_list with
1607-
| (_, label1, _, _) :: _ -> (
1608-
match label1.lbl_repres with
1609-
| Record_inlined {attrs; _}
1610-
when not (Ast_untagged_variants.process_untagged attrs) ->
1611-
let tag_name =
1612-
match Ast_untagged_variants.process_tag_name attrs with
1613-
| Some s -> s
1614-
| None -> "TAG"
1615-
in
1616-
if List.mem tag_name explicit_fields then explicit_fields
1617-
else tag_name :: explicit_fields
1618-
| _ -> explicit_fields)
1619-
| [] -> explicit_fields
1677+
match source_repr with
1678+
| Record_inlined {attrs; _}
1679+
when not (Ast_untagged_variants.process_untagged attrs) ->
1680+
let tag_name =
1681+
match Ast_untagged_variants.process_tag_name attrs with
1682+
| Some s -> s
1683+
| None -> "TAG"
1684+
in
1685+
if List.mem tag_name explicit_fields then explicit_fields
1686+
else tag_name :: explicit_fields
1687+
| _ -> explicit_fields
16201688
in
16211689
(* Get rest field names *)
16221690
let rest_field_names =
@@ -1640,47 +1708,36 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp
16401708
Record_rest_field_not_optional
16411709
(not_optional, rest_type_lid.txt) ));
16421710
(* Validate: all source fields must be in explicit or rest *)
1643-
(match lbl_pat_list with
1644-
| (_, label1, _, _) :: _ ->
1645-
let all_source = label1.lbl_all in
1646-
let missing =
1647-
Array.to_list all_source
1648-
|> List.filter_map (fun source_label ->
1649-
let name = source_label.lbl_name in
1650-
if
1651-
(not (List.mem name explicit_fields))
1652-
&& not (List.mem name rest_field_names)
1653-
then Some name
1654-
else None)
1655-
in
1656-
if missing <> [] then
1657-
raise
1658-
(Error
1659-
( rest_pat.ppat_loc,
1660-
!env,
1661-
Record_rest_field_missing (missing, rest_type_lid.txt) ))
1662-
| [] -> ());
1663-
(* Validate: rest type fields must all exist in source *)
1664-
(match lbl_pat_list with
1665-
| (_, label1, _, _) :: _ ->
1666-
let all_source = label1.lbl_all in
1667-
let source_field_names =
1668-
Array.to_list (Array.map (fun l -> l.lbl_name) all_source)
1669-
in
1670-
List.iter
1671-
(fun (rest_label : Types.label_declaration) ->
1672-
if
1673-
not
1674-
(List.mem (Ident.name rest_label.ld_id) source_field_names)
1675-
then
1676-
raise
1677-
(Error
1678-
( rest_type_lid.loc,
1679-
!env,
1680-
Record_rest_extra_field
1681-
(Ident.name rest_label.ld_id, rest_type_lid.txt) )))
1682-
rest_labels
1683-
| [] -> ());
1711+
let source_field_names = List.map fst source_fields in
1712+
let missing =
1713+
List.filter
1714+
(fun source_field ->
1715+
(not (List.mem source_field explicit_fields))
1716+
&& not (List.mem source_field rest_field_names))
1717+
source_field_names
1718+
in
1719+
if missing <> [] then
1720+
raise
1721+
(Error
1722+
( rest_pat.ppat_loc,
1723+
!env,
1724+
Record_rest_field_missing (missing, rest_type_lid.txt) ));
1725+
(* Validate: rest type fields must all exist in source and use compatible types *)
1726+
List.iter
1727+
(fun (rest_label : Types.label_declaration) ->
1728+
let rest_field = Ident.name rest_label.ld_id in
1729+
match List.assoc_opt rest_field source_fields with
1730+
| None ->
1731+
raise
1732+
(Error
1733+
( rest_type_lid.loc,
1734+
!env,
1735+
Record_rest_extra_field (rest_field, rest_type_lid.txt)
1736+
))
1737+
| Some source_type ->
1738+
unify_pat_types rest_type_lid.loc !env rest_label.ld_type
1739+
source_type)
1740+
rest_labels;
16841741
(* Warn if all rest fields are already explicit — the rest record will be empty *)
16851742
if
16861743
rest_field_names <> []
@@ -1690,31 +1747,6 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp
16901747
then
16911748
Location.prerr_warning rest_pat.ppat_loc
16921749
Warnings.Bs_record_rest_empty;
1693-
let rest_type_args =
1694-
match rest_type_args_syntax with
1695-
| [] -> List.map (fun _ -> newvar ()) rest_decl.type_params
1696-
| args ->
1697-
let n_args = List.length args in
1698-
let n_params = List.length rest_decl.type_params in
1699-
if n_args <> n_params then
1700-
raise
1701-
(Typetexp.Error
1702-
( rest_type_lid.loc,
1703-
!env,
1704-
Typetexp.Type_arity_mismatch
1705-
(rest_type_lid.txt, n_params, n_args) ));
1706-
List.map
1707-
(fun sty ->
1708-
let cty, force =
1709-
Typetexp.transl_simple_type_delayed !env sty
1710-
in
1711-
pattern_force := force :: !pattern_force;
1712-
cty.ctyp_type)
1713-
args
1714-
in
1715-
let rest_type_expr =
1716-
newgenty (Tconstr (rest_path, rest_type_args, ref Mnil))
1717-
in
17181750
let rest_ident =
17191751
enter_variable rest_pat.ppat_loc rest_name rest_type_expr
17201752
in

‎tests/build_tests/super_errors/expected/record_rest_field_type_mismatch.res.expected‎

Lines changed: 11 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,11 @@
1+
2+
We've found a bug for you!
3+
/.../fixtures/record_rest_field_type_mismatch.res:4:12-16
4+
5+
2 │ type wrong = {b: int}
6+
3 │
7+
4 │ let {a, ...wrong as rest} = ({a: 1, b: "x"}: source)
8+
5 │
9+
10+
This pattern matches values of type int
11+
but a pattern was expected which matches values of type string

‎tests/build_tests/super_errors/fixtures/record_rest_field_type_mismatch.res‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,4 @@
1+
type source = {a: int, b: string}
2+
type wrong = {b: int}
3+
4+
let {a, ...wrong as rest} = ({a: 1, b: "x"}: source)

0 commit comments

Comments
 (0)