Disambiguate optional labels

CHANGELOG.md

@@ -31,6 +31,7 @@
 - PPX v4: mark props type in externals as `@live` to avoid dead code warnings for prop fields in the editor tooling. https://github.com/rescript-lang/rescript-compiler/pull/6796
 - Fix unused attribute check for `@as`. https://github.com/rescript-lang/rescript-compiler/pull/6795
 - Reactivate unused attribute check for `@int`. https://github.com/rescript-lang/rescript-compiler/pull/6802
+- Fix issue where optional labels were not taken into account when disambiguating record value construction. https://github.com/rescript-lang/rescript-compiler/pull/6798
 
 #### :house: Internal
 

jscomp/ml/typecore.ml

@@ -311,6 +311,12 @@ let extract_concrete_variant env ty =
   | (p0, p, {type_kind=Type_open}) -> (p0, p, [])
   | _ -> raise Not_found
 
+let has_optional_labels ld =
+  match ld.lbl_repres with
+  | Record_optional_labels _ -> true
+  | Record_inlined {optional_labels} -> optional_labels <> []
+  | _ -> false
+
 let label_is_optional ld =
   match ld.lbl_repres with
   | Record_optional_labels lbls -> Ext_list.mem_string lbls ld.lbl_name
@@ -839,18 +845,24 @@ module Label = NameChoice (struct
   let unbound_name_error = Typetexp.unbound_label_error
 end)
 
-let disambiguate_label_by_ids keep closed ids labels =
-  let check_ids (lbl, _) =
+let disambiguate_label_by_ids closed ids labels =
+  let check_ids (lbl, _) = (* check that all ids are present *)
     let lbls = Hashtbl.create 8 in
     Array.iter (fun lbl -> Hashtbl.add lbls lbl.lbl_name ()) lbl.lbl_all;
-    List.for_all (Hashtbl.mem lbls) ids
-  and check_closed (lbl, _) =
-    (not closed || List.length ids = Array.length lbl.lbl_all)
+    List.for_all (Hashtbl.mem lbls) ids in
+  let mandatory_labels_are_present num_ids lbl = (* check that all mandatory labels are present *)
+    if has_optional_labels lbl then (
+      let mandatory_lbls = ref 0 in
+      Ext_array.iter lbl.lbl_all (fun l -> if not (label_is_optional l) then incr mandatory_lbls);
+      num_ids >= !mandatory_lbls)
+    else num_ids = Array.length lbl.lbl_all in
+  let check_closed (lbl, _) =
+    (not closed || mandatory_labels_are_present (List.length ids) lbl)
   in
   let labels' = Ext_list.filter labels check_ids in
-  if keep && labels' = [] then (false, labels) else
+  if labels' = [] then (false, labels) else
   let labels'' = Ext_list.filter labels' check_closed in
-  if keep && labels'' = [] then (false, labels') else (true, labels'')
+  if labels'' = [] then (false, labels') else (true, labels'')
 
 (* Only issue warnings once per record constructor/pattern *)
 let disambiguate_lid_a_list loc closed env opath lid_a_list =
@@ -879,8 +891,8 @@ let disambiguate_lid_a_list loc closed env opath lid_a_list =
       Typetexp.unbound_label_error env lid;
     let (ok, labels) =
       match opath with
-        Some (_, _) -> (true, scope) (* disambiguate only checks scope *)
-      | _  -> disambiguate_label_by_ids (opath=None) closed ids scope
+        Some _ -> (true, scope) (* disambiguate only checks scope *)
+      | _  -> disambiguate_label_by_ids closed ids scope
     in
     if ok then Label.disambiguate lid env opath labels ~warn ~scope
           else fst (List.hd labels) (* will fail later *)

jscomp/test/DisambiguateOptionalFields.res

@@ -0,0 +1,8 @@
+type t1 = {x:int, y:int}
+type t2 = {x:int, y:int, z?:int}
+
+let f1 = (v:t1) => v.x
+let f2 = (v:t2) => v.x
+
+let v = {x:3, y:4}
+let res = f2(v) // Check that t2 shadows t1