diff --git a/CHANGELOG.md b/CHANGELOG.md index 47921d5c87..a8b3587c0a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -56,10 +56,11 @@ These are only breaking changes for unformatted code. - Process `@set` annotation for field update as generating an uncurried function https://github.com/rescript-lang/rescript-compiler/pull/5846 - Treat uncurried application of primitives like curried application, which produces better output https://github.com/rescript-lang/rescript-compiler/pull/5851 -# 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 47b5d1735a..78aa270549 100644 --- a/jscomp/ml/typecore.ml +++ b/jscomp/ml/typecore.ml @@ -74,6 +74,7 @@ type error = | Labels_omitted of string list | Empty_record_literal | Uncurried_arity_mismatch of type_expr * int * int + | Field_not_optional of string * type_expr exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -309,6 +310,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' = @@ -1151,15 +1165,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] = '$' @@ -1878,15 +1885,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) @@ -3876,6 +3876,11 @@ let report_error env ppf = function type_expr typ; fprintf ppf "@ @[It is applied with @{%d@} argument%s but it requires @{%d@}.@]@]" args (if args = 0 then "" else "s") arity + | 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 f80f9584ba..502e4a689e 100644 --- a/jscomp/ml/typecore.mli +++ b/jscomp/ml/typecore.mli @@ -110,6 +110,7 @@ type error = | Labels_omitted of string list | Empty_record_literal | Uncurried_arity_mismatch of type_expr * int * int + | 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 c16a1390ac..5cfe0e8126 100644 --- a/lib/4.06.1/unstable/js_compiler.ml +++ b/lib/4.06.1/unstable/js_compiler.ml @@ -40696,6 +40696,7 @@ type error = | Labels_omitted of string list | Empty_record_literal | Uncurried_arity_mismatch of type_expr * int * int + | Field_not_optional of string * type_expr exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -40804,6 +40805,7 @@ type error = | Labels_omitted of string list | Empty_record_literal | Uncurried_arity_mismatch of type_expr * int * int + | Field_not_optional of string * type_expr exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -41039,6 +41041,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' = @@ -41881,15 +41896,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] = '$' @@ -42608,15 +42616,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) @@ -44606,6 +44607,11 @@ let report_error env ppf = function type_expr typ; fprintf ppf "@ @[It is applied with @{%d@} argument%s but it requires @{%d@}.@]@]" args (if args = 0 then "" else "s") arity + | 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 65ef64ec87..53f3aa0f68 100644 --- a/lib/4.06.1/unstable/js_playground_compiler.ml +++ b/lib/4.06.1/unstable/js_playground_compiler.ml @@ -40696,6 +40696,7 @@ type error = | Labels_omitted of string list | Empty_record_literal | Uncurried_arity_mismatch of type_expr * int * int + | Field_not_optional of string * type_expr exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -40804,6 +40805,7 @@ type error = | Labels_omitted of string list | Empty_record_literal | Uncurried_arity_mismatch of type_expr * int * int + | Field_not_optional of string * type_expr exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -41039,6 +41041,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' = @@ -41881,15 +41896,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] = '$' @@ -42608,15 +42616,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) @@ -44606,6 +44607,11 @@ let report_error env ppf = function type_expr typ; fprintf ppf "@ @[It is applied with @{%d@} argument%s but it requires @{%d@}.@]@]" args (if args = 0 then "" else "s") arity + | 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 5c7f94a9b2..ba6f40dabd 100644 --- a/lib/4.06.1/whole_compiler.ml +++ b/lib/4.06.1/whole_compiler.ml @@ -95690,6 +95690,7 @@ type error = | Labels_omitted of string list | Empty_record_literal | Uncurried_arity_mismatch of type_expr * int * int + | Field_not_optional of string * type_expr exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -95798,6 +95799,7 @@ type error = | Labels_omitted of string list | Empty_record_literal | Uncurried_arity_mismatch of type_expr * int * int + | Field_not_optional of string * type_expr exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -96033,6 +96035,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' = @@ -96875,15 +96890,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] = '$' @@ -97602,15 +97610,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) @@ -99600,6 +99601,11 @@ let report_error env ppf = function type_expr typ; fprintf ppf "@ @[It is applied with @{%d@} argument%s but it requires @{%d@}.@]@]" args (if args = 0 then "" else "s") arity + | 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