diff --git a/CHANGELOG.md b/CHANGELOG.md index cd600cf4a9..5285ba1e5d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -10,10 +10,11 @@ > - :house: [Internal] > - :nail_care: [Polish] -# 10.1.0-rc.6 +# 10.1.0 #### :bug: Bug Fix +- Fix issue where no error was reported when ? was used for non-optional fields. https://github.com/rescript-lang/rescript-compiler/pull/5853 - Fix issue where optional fields in inline records were not supported and would cause type errors https://github.com/rescript-lang/rescript-compiler/pull/5827 # 10.1.0-rc.5 diff --git a/jscomp/build_tests/super_errors/expected/fieldNotOptional.res.expected b/jscomp/build_tests/super_errors/expected/fieldNotOptional.res.expected new file mode 100644 index 0000000000..c4069fbeaa --- /dev/null +++ b/jscomp/build_tests/super_errors/expected/fieldNotOptional.res.expected @@ -0,0 +1,11 @@ + + We've found a bug for you! + /.../fixtures/fieldNotOptional.res:3:19 + + 1 │ type r = {nonopt: int, opt?: string} + 2 │ + 3 │ let v = {nonopt: ?3, opt: ?None} + 4 │ + 5 │ let f = r => + + Field nonopt is not optional in type r. Use without ? \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/fixtures/fieldNotOptional.res b/jscomp/build_tests/super_errors/fixtures/fieldNotOptional.res new file mode 100644 index 0000000000..e653cbd9e6 --- /dev/null +++ b/jscomp/build_tests/super_errors/fixtures/fieldNotOptional.res @@ -0,0 +1,17 @@ +type r = {nonopt: int, opt?: string} + +let v = {nonopt: ?3, opt: ?None} + +let f = r => + switch r { + | {nonopt: ?_, opt: ?_} => true + } + +type inline = A({nonopt: int, opt?: string}) + +let vi = A({nonopt: ?3, opt: ?None}) + +let fi = a => + switch a { + | A ({nonopt: ?_, opt: ?_}) => true + } \ No newline at end of file diff --git a/jscomp/ml/typecore.ml b/jscomp/ml/typecore.ml index f0d46e94b5..afc9488684 100644 --- a/jscomp/ml/typecore.ml +++ b/jscomp/ml/typecore.ml @@ -73,6 +73,7 @@ type error = | Illegal_letrec_pat | Labels_omitted of string list | Empty_record_literal + | Field_not_optional of string * type_expr exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -308,6 +309,19 @@ let extract_concrete_variant env ty = | (p0, p, {type_kind=Type_open}) -> (p0, p, []) | _ -> raise Not_found +let label_is_optional ld = + match ld.lbl_repres with + | Record_optional_labels lbls -> Ext_list.mem_string lbls ld.lbl_name + | Record_inlined {optional_labels} -> Ext_list.mem_string optional_labels ld.lbl_name + | _ -> false + +let check_optional_attr env ld attrs loc = + let check_redundant () = + if not (label_is_optional ld) then + raise (Error (loc, env, Field_not_optional (ld.lbl_name, ld.lbl_res))); + true in + Ext_list.exists attrs (fun ({txt}, _) -> + txt = "ns.optional" && check_redundant ()) (* unification inside type_pat*) let unify_pat_types loc env ty ty' = @@ -1150,15 +1164,8 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env Some (p0, p), expected_ty with Not_found -> None, newvar () in - let label_is_optional ld = - match ld.lbl_repres with - | Record_optional_labels lbls -> Ext_list.mem_string lbls ld.lbl_name - | Record_inlined {optional_labels} -> Ext_list.mem_string optional_labels ld.lbl_name - | _ -> false in let process_optional_label (ld, pat) = - let exp_optional_attr = - Ext_list.exists pat.ppat_attributes (fun ({txt },_) -> txt = "ns.optional") - in + let exp_optional_attr = check_optional_attr !env ld pat.ppat_attributes pat.ppat_loc in let isFromPamatch = match pat.ppat_desc with | Ppat_construct ({txt = Lident s}, _) -> String.length s >= 2 && s.[0] = '#' && s.[1] = '$' @@ -1877,15 +1884,8 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = unify_exp env (re exp) (instance env ty_expected); exp in - let label_is_optional ld = - match ld.lbl_repres with - | Record_optional_labels lbls -> Ext_list.mem_string lbls ld.lbl_name - | Record_inlined {optional_labels} -> Ext_list.mem_string optional_labels ld.lbl_name - | _ -> false in let process_optional_label (id, ld, e) = - let exp_optional_attr = - Ext_list.exists e.pexp_attributes (fun ({txt },_) -> txt = "ns.optional") - in + let exp_optional_attr = check_optional_attr env ld e.pexp_attributes e.pexp_loc in if label_is_optional ld && not exp_optional_attr then let lid = mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))) in let e = Ast_helper.Exp.construct ~loc:e.pexp_loc lid (Some e) @@ -3797,6 +3797,11 @@ let report_error env ppf = function (String.concat ", " labels) | Empty_record_literal -> fprintf ppf "Empty record literal {} should be type annotated or used in a record context." + | Field_not_optional (name, typ) -> + fprintf ppf + "Field @{%s@} is not optional in type %a. Use without ?" name + type_expr typ + let super_report_error_no_wrap_printing_env = report_error diff --git a/jscomp/ml/typecore.mli b/jscomp/ml/typecore.mli index 8f788b65c5..7c1cb523f4 100644 --- a/jscomp/ml/typecore.mli +++ b/jscomp/ml/typecore.mli @@ -109,6 +109,7 @@ type error = | Illegal_letrec_pat | Labels_omitted of string list | Empty_record_literal + | Field_not_optional of string * type_expr exception Error of Location.t * Env.t * error exception Error_forward of Location.error diff --git a/lib/4.06.1/unstable/js_compiler.ml b/lib/4.06.1/unstable/js_compiler.ml index 1a53766017..05e5c1e98c 100644 --- a/lib/4.06.1/unstable/js_compiler.ml +++ b/lib/4.06.1/unstable/js_compiler.ml @@ -40690,6 +40690,7 @@ type error = | Illegal_letrec_pat | Labels_omitted of string list | Empty_record_literal + | Field_not_optional of string * type_expr exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -40797,6 +40798,7 @@ type error = | Illegal_letrec_pat | Labels_omitted of string list | Empty_record_literal + | Field_not_optional of string * type_expr exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -41032,6 +41034,19 @@ let extract_concrete_variant env ty = | (p0, p, {type_kind=Type_open}) -> (p0, p, []) | _ -> raise Not_found +let label_is_optional ld = + match ld.lbl_repres with + | Record_optional_labels lbls -> Ext_list.mem_string lbls ld.lbl_name + | Record_inlined {optional_labels} -> Ext_list.mem_string optional_labels ld.lbl_name + | _ -> false + +let check_optional_attr env ld attrs loc = + let check_redundant () = + if not (label_is_optional ld) then + raise (Error (loc, env, Field_not_optional (ld.lbl_name, ld.lbl_res))); + true in + Ext_list.exists attrs (fun ({txt}, _) -> + txt = "ns.optional" && check_redundant ()) (* unification inside type_pat*) let unify_pat_types loc env ty ty' = @@ -41874,15 +41889,8 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env Some (p0, p), expected_ty with Not_found -> None, newvar () in - let label_is_optional ld = - match ld.lbl_repres with - | Record_optional_labels lbls -> Ext_list.mem_string lbls ld.lbl_name - | Record_inlined {optional_labels} -> Ext_list.mem_string optional_labels ld.lbl_name - | _ -> false in let process_optional_label (ld, pat) = - let exp_optional_attr = - Ext_list.exists pat.ppat_attributes (fun ({txt },_) -> txt = "ns.optional") - in + let exp_optional_attr = check_optional_attr !env ld pat.ppat_attributes pat.ppat_loc in let isFromPamatch = match pat.ppat_desc with | Ppat_construct ({txt = Lident s}, _) -> String.length s >= 2 && s.[0] = '#' && s.[1] = '$' @@ -42601,15 +42609,8 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = unify_exp env (re exp) (instance env ty_expected); exp in - let label_is_optional ld = - match ld.lbl_repres with - | Record_optional_labels lbls -> Ext_list.mem_string lbls ld.lbl_name - | Record_inlined {optional_labels} -> Ext_list.mem_string optional_labels ld.lbl_name - | _ -> false in let process_optional_label (id, ld, e) = - let exp_optional_attr = - Ext_list.exists e.pexp_attributes (fun ({txt },_) -> txt = "ns.optional") - in + let exp_optional_attr = check_optional_attr env ld e.pexp_attributes e.pexp_loc in if label_is_optional ld && not exp_optional_attr then let lid = mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))) in let e = Ast_helper.Exp.construct ~loc:e.pexp_loc lid (Some e) @@ -44521,6 +44522,11 @@ let report_error env ppf = function (String.concat ", " labels) | Empty_record_literal -> fprintf ppf "Empty record literal {} should be type annotated or used in a record context." + | Field_not_optional (name, typ) -> + fprintf ppf + "Field @{%s@} is not optional in type %a. Use without ?" name + type_expr typ + let super_report_error_no_wrap_printing_env = report_error diff --git a/lib/4.06.1/unstable/js_playground_compiler.ml b/lib/4.06.1/unstable/js_playground_compiler.ml index 57ac3378e5..d695518b4f 100644 --- a/lib/4.06.1/unstable/js_playground_compiler.ml +++ b/lib/4.06.1/unstable/js_playground_compiler.ml @@ -40690,6 +40690,7 @@ type error = | Illegal_letrec_pat | Labels_omitted of string list | Empty_record_literal + | Field_not_optional of string * type_expr exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -40797,6 +40798,7 @@ type error = | Illegal_letrec_pat | Labels_omitted of string list | Empty_record_literal + | Field_not_optional of string * type_expr exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -41032,6 +41034,19 @@ let extract_concrete_variant env ty = | (p0, p, {type_kind=Type_open}) -> (p0, p, []) | _ -> raise Not_found +let label_is_optional ld = + match ld.lbl_repres with + | Record_optional_labels lbls -> Ext_list.mem_string lbls ld.lbl_name + | Record_inlined {optional_labels} -> Ext_list.mem_string optional_labels ld.lbl_name + | _ -> false + +let check_optional_attr env ld attrs loc = + let check_redundant () = + if not (label_is_optional ld) then + raise (Error (loc, env, Field_not_optional (ld.lbl_name, ld.lbl_res))); + true in + Ext_list.exists attrs (fun ({txt}, _) -> + txt = "ns.optional" && check_redundant ()) (* unification inside type_pat*) let unify_pat_types loc env ty ty' = @@ -41874,15 +41889,8 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env Some (p0, p), expected_ty with Not_found -> None, newvar () in - let label_is_optional ld = - match ld.lbl_repres with - | Record_optional_labels lbls -> Ext_list.mem_string lbls ld.lbl_name - | Record_inlined {optional_labels} -> Ext_list.mem_string optional_labels ld.lbl_name - | _ -> false in let process_optional_label (ld, pat) = - let exp_optional_attr = - Ext_list.exists pat.ppat_attributes (fun ({txt },_) -> txt = "ns.optional") - in + let exp_optional_attr = check_optional_attr !env ld pat.ppat_attributes pat.ppat_loc in let isFromPamatch = match pat.ppat_desc with | Ppat_construct ({txt = Lident s}, _) -> String.length s >= 2 && s.[0] = '#' && s.[1] = '$' @@ -42601,15 +42609,8 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = unify_exp env (re exp) (instance env ty_expected); exp in - let label_is_optional ld = - match ld.lbl_repres with - | Record_optional_labels lbls -> Ext_list.mem_string lbls ld.lbl_name - | Record_inlined {optional_labels} -> Ext_list.mem_string optional_labels ld.lbl_name - | _ -> false in let process_optional_label (id, ld, e) = - let exp_optional_attr = - Ext_list.exists e.pexp_attributes (fun ({txt },_) -> txt = "ns.optional") - in + let exp_optional_attr = check_optional_attr env ld e.pexp_attributes e.pexp_loc in if label_is_optional ld && not exp_optional_attr then let lid = mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))) in let e = Ast_helper.Exp.construct ~loc:e.pexp_loc lid (Some e) @@ -44521,6 +44522,11 @@ let report_error env ppf = function (String.concat ", " labels) | Empty_record_literal -> fprintf ppf "Empty record literal {} should be type annotated or used in a record context." + | Field_not_optional (name, typ) -> + fprintf ppf + "Field @{%s@} is not optional in type %a. Use without ?" name + type_expr typ + let super_report_error_no_wrap_printing_env = report_error diff --git a/lib/4.06.1/whole_compiler.ml b/lib/4.06.1/whole_compiler.ml index e67bd9090b..dabce93269 100644 --- a/lib/4.06.1/whole_compiler.ml +++ b/lib/4.06.1/whole_compiler.ml @@ -216862,6 +216862,7 @@ type error = | Illegal_letrec_pat | Labels_omitted of string list | Empty_record_literal + | Field_not_optional of string * type_expr exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -216969,6 +216970,7 @@ type error = | Illegal_letrec_pat | Labels_omitted of string list | Empty_record_literal + | Field_not_optional of string * type_expr exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -217204,6 +217206,19 @@ let extract_concrete_variant env ty = | (p0, p, {type_kind=Type_open}) -> (p0, p, []) | _ -> raise Not_found +let label_is_optional ld = + match ld.lbl_repres with + | Record_optional_labels lbls -> Ext_list.mem_string lbls ld.lbl_name + | Record_inlined {optional_labels} -> Ext_list.mem_string optional_labels ld.lbl_name + | _ -> false + +let check_optional_attr env ld attrs loc = + let check_redundant () = + if not (label_is_optional ld) then + raise (Error (loc, env, Field_not_optional (ld.lbl_name, ld.lbl_res))); + true in + Ext_list.exists attrs (fun ({txt}, _) -> + txt = "ns.optional" && check_redundant ()) (* unification inside type_pat*) let unify_pat_types loc env ty ty' = @@ -218046,15 +218061,8 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env Some (p0, p), expected_ty with Not_found -> None, newvar () in - let label_is_optional ld = - match ld.lbl_repres with - | Record_optional_labels lbls -> Ext_list.mem_string lbls ld.lbl_name - | Record_inlined {optional_labels} -> Ext_list.mem_string optional_labels ld.lbl_name - | _ -> false in let process_optional_label (ld, pat) = - let exp_optional_attr = - Ext_list.exists pat.ppat_attributes (fun ({txt },_) -> txt = "ns.optional") - in + let exp_optional_attr = check_optional_attr !env ld pat.ppat_attributes pat.ppat_loc in let isFromPamatch = match pat.ppat_desc with | Ppat_construct ({txt = Lident s}, _) -> String.length s >= 2 && s.[0] = '#' && s.[1] = '$' @@ -218773,15 +218781,8 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = unify_exp env (re exp) (instance env ty_expected); exp in - let label_is_optional ld = - match ld.lbl_repres with - | Record_optional_labels lbls -> Ext_list.mem_string lbls ld.lbl_name - | Record_inlined {optional_labels} -> Ext_list.mem_string optional_labels ld.lbl_name - | _ -> false in let process_optional_label (id, ld, e) = - let exp_optional_attr = - Ext_list.exists e.pexp_attributes (fun ({txt },_) -> txt = "ns.optional") - in + let exp_optional_attr = check_optional_attr env ld e.pexp_attributes e.pexp_loc in if label_is_optional ld && not exp_optional_attr then let lid = mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))) in let e = Ast_helper.Exp.construct ~loc:e.pexp_loc lid (Some e) @@ -220693,6 +220694,11 @@ let report_error env ppf = function (String.concat ", " labels) | Empty_record_literal -> fprintf ppf "Empty record literal {} should be type annotated or used in a record context." + | Field_not_optional (name, typ) -> + fprintf ppf + "Field @{%s@} is not optional in type %a. Use without ?" name + type_expr typ + let super_report_error_no_wrap_printing_env = report_error