10.1_release -> master (#5855)

cknitt · cristianoc · web-flow · commit b26bede69f0a · 2022-11-27T10:58:13.000+01:00
* Print error message when `?` is used for non-optional fields. * Add CHANGELOG entry * Set version to 10.1.0 (#5848) Co-authored-by: Cristiano Calcagno <cristianoc@users.noreply.github.com>
diff --git 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
@@ -0,0 +1,11 @@
+
+  [1;31mWe've found a bug for you![0m
+  [36m/.../fixtures/fieldNotOptional.res[0m:[2m3:19[0m
+
+  1 [2m│[0m type r = {nonopt: int, opt?: string}
+  2 [2m│[0m 
+  [1;31m3[0m [2m│[0m let v = {nonopt: ?[1;31m3[0m, opt: ?None}
+  4 [2m│[0m 
+  5 [2m│[0m let f = r =>
+
+  Field [1;33mnonopt[0m is not optional in type r. Use without ?
diff --git a/jscomp/build_tests/super_errors/fixtures/fieldNotOptional.res 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
+  }
diff --git 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 @{<error>%d@} argument%s but it requires @{<info>%d@}.@]@]"
       args (if args = 0 then "" else "s") arity
+  | Field_not_optional (name, typ) ->
+    fprintf ppf
+    "Field @{<info>%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
@@ -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
@@ -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 @{<error>%d@} argument%s but it requires @{<info>%d@}.@]@]"
       args (if args = 0 then "" else "s") arity
+  | Field_not_optional (name, typ) ->
+    fprintf ppf
+    "Field @{<info>%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
@@ -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 @{<error>%d@} argument%s but it requires @{<info>%d@}.@]@]"
       args (if args = 0 then "" else "s") arity
+  | Field_not_optional (name, typ) ->
+    fprintf ppf
+    "Field @{<info>%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
@@ -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 @{<error>%d@} argument%s but it requires @{<info>%d@}.@]@]"
       args (if args = 0 then "" else "s") arity
+  | Field_not_optional (name, typ) ->
+    fprintf ppf
+    "Field @{<info>%s@} is not optional in type %a. Use without ?" name
+    type_expr typ
+
 
 let super_report_error_no_wrap_printing_env = report_error
 

-Original file line number
+Diff line change
@@ @@ -0,0 +1,11 @@ @@
++
 +  [1;31mWe've found a bug for you![0m
 +  [36m/.../fixtures/fieldNotOptional.res[0m:[2m3:19[0m
++
 +  1 [2m│[0m type r = {nonopt: int, opt?: string}
 +  2 [2m│[0m
 +  [1;31m3[0m [2m│[0m let v = {nonopt: ?[1;31m3[0m, opt: ?None}
 +  4 [2m│[0m
 +  5 [2m│[0m let f = r =>
++
 +  Field [1;33mnonopt[0m is not optional in type r. Use without ?