rescript-lang · DZakh · Aug 17, 2024
diff --git a/jscomp/gentype/TranslateTypeDeclarations.ml b/jscomp/gentype/TranslateTypeDeclarations.ml
@@ -90,7 +90,8 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver
       label_declarations =
     let is_optional l =
       match record_representation with
-      | Types.Record_optional_labels lbls -> List.mem l lbls
+      | Types.Record_regular {has_optional = true; optional_labels = lbls} ->
+        List.mem l lbls
       | _ -> false
     in
     let field_translations =
@@ -251,7 +252,9 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver
                  [
                    label_declarations
                    |> translate_label_declarations ~inline:true
-                        ~record_representation:Types.Record_regular;
+                        ~record_representation:
+                          (Types.Record_regular
+                             {has_optional = false; optional_labels = []});
                  ]
              in
              let arg_types =

diff --git a/jscomp/ml/ctype.ml b/jscomp/ml/ctype.ml
@@ -3670,7 +3670,7 @@ let rec subtype_rec env trace t1 t2 cstrs =
             else (trace, t1, t2, !univar_pairs)::cstrs
       | (_, _, {type_kind=Type_record (fields1, repr1)}), (_, _, {type_kind=Type_record (fields2, repr2)}) ->
         let same_repr = match repr1, repr2 with
-          | (Record_regular | Record_optional_labels _), (Record_regular | Record_optional_labels _) ->
+          | (Record_regular _), (Record_regular _) ->
             true (* handled in the fields checks *)
           | Record_unboxed b1, Record_unboxed b2 -> b1 = b2
           | Record_inlined _, Record_inlined _ -> repr1 = repr2

diff --git a/jscomp/ml/datarepr.ml b/jscomp/ml/datarepr.ml
@@ -216,7 +216,7 @@ let none = {desc = Ttuple []; level = -1; id = -1}
                                         (* Clearly ill-formed type *)
 let dummy_label =
   { lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable;
-    lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular;
+    lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular {has_optional = false; optional_labels = []};
     lbl_private = Public;
     lbl_loc = Location.none;
     lbl_attributes = [];

diff --git a/jscomp/ml/includecore.ml b/jscomp/ml/includecore.ml
@@ -166,7 +166,7 @@ let report_type_mismatch0 first second decl ppf err =
   | Record_representation (rep1, rep2) ->
       let default () = pr "Their internal representations differ" in
       ( match rep1, rep2 with
-        | Record_optional_labels lbls1, Record_optional_labels lbls2 ->
+        | Record_regular {has_optional=true;optional_labels=lbls1}, Record_regular {has_optional=true;optional_labels=lbls2} ->
           let only_in_lhs =
             Ext_list.find_first lbls1 (fun l -> not (Ext_list.mem_string lbls2 l)) in
           let only_in_rhs =

diff --git a/jscomp/ml/matching.ml b/jscomp/ml/matching.ml
@@ -1596,8 +1596,7 @@ let make_record_matching loc all_labels def = function
           let lbl = all_labels.(pos) in
           let access =
             match lbl.lbl_repres with
-            | Record_float_unused -> assert false
-            | Record_regular | Record_optional_labels _ -> 
+            | Record_regular _ -> 
               Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [arg], loc) 
             | Record_inlined _ ->
               Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), [arg], loc)

diff --git a/jscomp/ml/printtyped.ml b/jscomp/ml/printtyped.ml
@@ -144,10 +144,9 @@ let arg_label i ppf = function
 ;;
 
 let record_representation i ppf = let open Types in function
-  | Record_regular -> line i ppf "Record_regular\n"
-  | Record_float_unused -> assert false
-  | Record_optional_labels lbls ->
-    line i ppf "Record_optional_labels %s\n" (lbls |> String.concat ", ")
+  | Record_regular {has_optional=false} -> line i ppf "Record_regular\n"
+  | Record_regular {has_optional=true; optional_labels} ->
+    line i ppf "Record_optional_labels %s\n" (optional_labels |> String.concat ", ")
   | Record_unboxed b -> line i ppf "Record_unboxed %b\n" b
   | Record_inlined {tag = i} -> line i ppf "Record_inlined %d\n" i
   | Record_extension -> line i ppf "Record_extension\n"

diff --git a/jscomp/ml/rec_check.ml b/jscomp/ml/rec_check.ml
@@ -255,8 +255,7 @@ let rec expression : Env.env -> Typedtree.expression -> Use.t =
       let use =
         match rep with
         | Record_unboxed _ -> fun x -> x
-        | Record_float_unused -> assert false
-        | Record_optional_labels _ | Record_regular | Record_inlined _ | Record_extension
+        | Record_regular _ | Record_inlined _ | Record_extension
           ->
             Use.guard
       in

diff --git a/jscomp/ml/record_coercion.ml b/jscomp/ml/record_coercion.ml
@@ -2,7 +2,7 @@ let check_record_fields ?repr1 ?repr2 (fields1 : Types.label_declaration list)
     (fields2 : Types.label_declaration list) =
   let field_is_optional id repr =
     match repr with
-    | Some (Types.Record_optional_labels lbls) -> List.mem (Ident.name id) lbls
+    | Some (Types.Record_regular {has_optional = true; optional_labels = lbls}) -> List.mem (Ident.name id) lbls
     | _ -> false
   in
   let violation = ref false in

diff --git a/jscomp/ml/translcore.ml b/jscomp/ml/translcore.ml
@@ -933,8 +933,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda =
   | Texp_field (arg, _, lbl) -> (
       let targ = transl_exp arg in
       match lbl.lbl_repres with
-      | Record_float_unused -> assert false
-      | Record_regular | Record_optional_labels _ ->
+      | Record_regular _ ->
           Lprim
             (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [ targ ], e.exp_loc)
       | Record_inlined _ ->
@@ -952,8 +951,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda =
   | Texp_setfield (arg, _, lbl, newval) ->
       let access =
         match lbl.lbl_repres with
-        | Record_float_unused -> assert false
-        | Record_regular | Record_optional_labels _ ->
+        | Record_regular _ ->
             Psetfield (lbl.lbl_pos, Lambda.fld_record_set lbl)
         | Record_inlined _ ->
             Psetfield (lbl.lbl_pos, Lambda.fld_record_inline_set lbl)
@@ -1191,7 +1189,7 @@ and transl_record loc env fields repres opt_init_expr =
          functional-style record update *)
       let no_init = match opt_init_expr with None -> true | _ -> false in
       if
-        no_init || (size < 20 && (match repres with Record_optional_labels _ -> false | _ -> true))
+        no_init || (size < 20 && (match repres with Record_regular {has_optional=true} -> false | _ -> true))
         (* TODO: More strategies
            3 + 2 * List.length lbl_expr_list >= size (density)
         *)
@@ -1206,8 +1204,7 @@ and transl_record loc env fields repres opt_init_expr =
               | Kept _ ->
                   let access =
                     match repres with
-                    | Record_float_unused -> assert false
-                    | Record_regular | Record_optional_labels _ ->
+                    | Record_regular _ ->
                         Pfield (i, Lambda.fld_record lbl)
                     | Record_inlined _ ->
                         Pfield (i, Lambda.fld_record_inline lbl)
@@ -1231,13 +1228,9 @@ and transl_record loc env fields repres opt_init_expr =
             if mut = Mutable then raise Not_constant;
             let cl = List.map extract_constant ll in
             match repres with
-            | Record_float_unused -> assert false
-            | Record_regular ->
+            | Record_regular {has_optional} ->
                 Lconst
-                  (Const_block (Lambda.blk_record fields mut Record_regular, cl))
-            | Record_optional_labels _ ->
-                Lconst
-                  (Const_block (Lambda.blk_record fields mut Record_optional, cl))
+                  (Const_block (Lambda.blk_record fields mut (if has_optional then Record_optional else Record_regular), cl))
             | Record_inlined { tag; name; num_nonconsts; optional_labels; attrs } ->
                 Lconst
                   (Const_block
@@ -1249,17 +1242,11 @@ and transl_record loc env fields repres opt_init_expr =
             | Record_extension -> raise Not_constant
           with Not_constant -> (
             match repres with
-            | Record_regular ->
-                Lprim
-                  ( Pmakeblock (Lambda.blk_record fields mut Record_regular),
-                    ll,
-                    loc )
-            | Record_optional_labels _ ->
+            | Record_regular {has_optional}->
                 Lprim
-                  ( Pmakeblock (Lambda.blk_record fields mut Record_optional),
+                  ( Pmakeblock (Lambda.blk_record fields mut (if has_optional then Record_optional else Record_regular)),
                     ll,
                     loc )
-            | Record_float_unused -> assert false
             | Record_inlined { tag; name; num_nonconsts; optional_labels; attrs } ->
                 Lprim
                   ( Pmakeblock
@@ -1296,8 +1283,7 @@ and transl_record loc env fields repres opt_init_expr =
           | Overridden (_lid, expr) ->
               let upd =
                 match repres with
-                | Record_float_unused -> assert false
-                | Record_regular | Record_optional_labels _ ->
+                | Record_regular _ ->
                     Psetfield (lbl.lbl_pos, Lambda.fld_record_set lbl)
                 | Record_inlined _ ->
                     Psetfield (lbl.lbl_pos, Lambda.fld_record_inline_set lbl)

diff --git a/jscomp/ml/typecore.ml b/jscomp/ml/typecore.ml
@@ -311,13 +311,13 @@ let extract_concrete_variant env ty =
 
 let has_optional_labels ld =
   match ld.lbl_repres with
-  | Record_optional_labels _ -> true
+  | Record_regular {has_optional} -> has_optional
   | 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
+  | Record_regular {has_optional = true; optional_labels} -> Ext_list.mem_string optional_labels ld.lbl_name
   | Record_inlined {optional_labels} -> Ext_list.mem_string optional_labels ld.lbl_name
   | _ -> false
 
@@ -2293,7 +2293,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg=Rejected) env sexp ty
         | (_, { lbl_all = label_descriptions; lbl_repres = representation}, _) :: _, _ -> label_descriptions, representation
         | [], Some (representation) when lid_sexp_list = [] ->
             let optional_labels = match representation with
-            | Record_optional_labels optional_labels -> optional_labels
+            | Record_regular {optional_labels}
             | Record_inlined {optional_labels} -> optional_labels
             | _ -> [] in
             let filter_missing (ld : Types.label_declaration) =
@@ -2309,7 +2309,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg=Rejected) env sexp ty
             [||], representation
         | [], _ ->
           if fields = [] && repr_opt <> None then
-            [||], Record_optional_labels []
+            [||], Record_regular {has_optional = false; optional_labels = []}
           else
             raise(Error(loc, env, Empty_record_literal)) in
         let labels_missing = ref [] in

diff --git a/jscomp/ml/typedecl.ml b/jscomp/ml/typedecl.ml
@@ -549,9 +549,10 @@ let transl_declaration ~type_record_as_object env sdecl id =
             in
             Ttype_record lbls, Type_record(lbls', if unbox then 
                 Record_unboxed false
-              else if optional_labels <> [] then 
-                Record_optional_labels optional_labels
-              else Record_regular), sdecl
+              else Record_regular {
+                has_optional = optional_labels <> [];
+                optional_labels = optional_labels
+              }), sdecl
           | None ->
              (* Could not find record type decl for ...t: assume t is an object type and this is syntax ambiguity *)
              type_record_as_object := true;

diff --git a/jscomp/ml/types.ml b/jscomp/ml/types.ml
@@ -150,14 +150,15 @@ and type_kind =
   | Type_open
 
 and record_representation =
-  | Record_regular                        (* All fields are boxed / tagged *)
-  | Record_float_unused                   (* Was: all fields are floats. Now: unused *)
+  | Record_regular of {
+    has_optional: bool;                   (* true if optional_labels is non-empty. Needed for convinience to match on Record_regular with optional labels only *)
+    optional_labels : string list
+  }                                       (* All fields are boxed / tagged *)
   | Record_unboxed of bool                (* Unboxed single-field record, inlined or not *)
   | Record_inlined of                     (* Inlined record *)
-      { tag : int ; name : string; num_nonconsts : int; optional_labels : string list; attrs: Parsetree.attributes}
+      { tag : int ; name : string; num_nonconsts : int; optional_labels : string list; attrs: Parsetree.attributes }
   | Record_extension                      (* Inlined record under extension *)
-  | Record_optional_labels of string list (* List of optional labels *)
-
+
 and label_declaration =
   {
     ld_id: Ident.t;
@@ -310,11 +311,10 @@ type label_description =
    }
 let same_record_representation x y =
   match x with
-  | Record_regular -> y = Record_regular
-  | Record_float_unused -> y = Record_float_unused
-  | Record_optional_labels lbls -> (
+  | Record_regular {optional_labels} -> (
       match y with
-      | Record_optional_labels lbls2 -> lbls = lbls2
+      | Record_regular y ->
+          optional_labels = y.optional_labels
       | _ -> false)
   | Record_inlined {tag; name; num_nonconsts; optional_labels} -> (
       match y with

diff --git a/jscomp/ml/types.mli b/jscomp/ml/types.mli
@@ -297,13 +297,14 @@ and type_kind =
   | Type_open
 
 and record_representation =
-  | Record_regular                        (* All fields are boxed / tagged *)
-  | Record_float_unused                   (* Was: all fields are floats. Now: unused *)
+  | Record_regular of {
+    has_optional: bool;                   (* true if optional_labels is non-empty. Needed for convinience to match on Record_regular with optional labels only *)
+    optional_labels : string list
+  }                                       (* All fields are boxed / tagged *)
   | Record_unboxed of bool                (* Unboxed single-field record, inlined or not *)
   | Record_inlined of                     (* Inlined record *)
       { tag : int ; name : string; num_nonconsts : int; optional_labels : string list; attrs: Parsetree.attributes }
   | Record_extension                      (* Inlined record under extension *)
-  | Record_optional_labels of string list (* List of optional labels *)
 
 and label_declaration =
   {