Clean up Record_optional_labels

CHANGELOG.md

@@ -20,6 +20,8 @@
 - Use latest compiler for tests. https://github.com/rescript-lang/rescript/pull/7186
 - Added infra to modernise AST: theres' Parsetree, Parsetree0 (legacy), and conversion functions to keep compatibility with PPX. https://github.com/rescript-lang/rescript/pull/7185
 - Ast cleanup: remove exp object and exp unreachable. https://github.com/rescript-lang/rescript/pull/7189
+- Ast cleanup: explicit representation for optional record fields in types. https://github.com/rescript-lang/rescript/pull/7190 https://github.com/rescript-lang/rescript/pull/7191
+
 
 # 12.0.0-alpha.5
 

analysis/src/CreateInterface.ml

@@ -145,12 +145,7 @@ let printSignature ~extractor ~signature =
   let rec processSignature ~indent (signature : Types.signature) : unit =
     match signature with
     | Sig_type
-        ( propsId,
-          {
-            type_params;
-            type_kind = Type_record (labelDecls, recordRepresentation);
-          },
-          _ )
+        (propsId, {type_params; type_kind = Type_record (labelDecls, _)}, _)
       :: Sig_value (makeId (* make *), makeValueDesc)
       :: rest
       when Ident.name propsId = "props"
@@ -175,12 +170,7 @@ let printSignature ~extractor ~signature =
             in
             let lblName = labelDecl.ld_id |> Ident.name in
             let lbl =
-              let optLbls =
-                match recordRepresentation with
-                | Record_optional_labels optLbls -> optLbls
-                | _ -> []
-              in
-              if List.mem lblName optLbls then Asttypes.Optional lblName
+              if labelDecl.ld_optional then Asttypes.Optional lblName
               else Labelled lblName
             in
             {retType with desc = Tarrow (lbl, propType, mkFunType rest, Cok)}

compiler/core/js_dump.ml

@@ -759,24 +759,19 @@ and expression_desc cxt ~(level : int) f x : cxt =
            Ext_list.map_combine fields el (fun x ->
                Js_op.Lit (Ext_ident.convert x)) ))
   (*name convention of Record is slight different from modules*)
-  | Caml_block (el, mutable_flag, _, Blk_record {fields; record_repr}) -> (
+  | Caml_block (el, mutable_flag, _, Blk_record {fields}) ->
     if
       Array.length fields <> 0
-      && Ext_array.for_alli fields (fun i v -> string_of_int i = v)
+      && Ext_array.for_alli fields (fun i (v, _) -> string_of_int i = v)
     then expression_desc cxt ~level f (Array (el, mutable_flag))
     else
-      match record_repr with
-      | Record_regular ->
-        expression_desc cxt ~level f
-          (Object (None, Ext_list.combine_array fields el (fun i -> Js_op.Lit i)))
-      | Record_optional ->
-        let fields =
-          Ext_list.array_list_filter_map fields el (fun f x ->
-              match x.expression_desc with
-              | Undefined _ -> None
-              | _ -> Some (Js_op.Lit f, x))
-        in
-        expression_desc cxt ~level f (Object (None, fields)))
+      let fields =
+        Ext_list.array_list_filter_map fields el (fun (f, opt) x ->
+            match x.expression_desc with
+            | Undefined _ when opt -> None
+            | _ -> Some (Js_op.Lit f, x))
+      in
+      expression_desc cxt ~level f (Object (None, fields))
   | Caml_block (el, _, _, Blk_poly_var _) -> (
     match el with
     | [tag; value] ->
@@ -794,28 +789,18 @@ and expression_desc cxt ~(level : int) f x : cxt =
     let untagged = Ast_untagged_variants.process_untagged p.attrs in
     let objs =
       let tails =
-        Ext_list.combine_array_append p.fields el
-          (if !Js_config.debug then [(name_symbol, E.str p.name)] else [])
-          (fun i -> Js_op.Lit i)
-      in
-      let is_optional (pname : Js_op.property_name) =
-        match pname with
-        | Lit n -> Ext_list.mem_string p.optional_labels n
-        | Symbol_name -> false
+        Ext_list.combine_array p.fields el (fun (i, opt) -> (Js_op.Lit i, opt))
       in
       let tag_name =
         match Ast_untagged_variants.process_tag_name p.attrs with
         | None -> L.tag
         | Some s -> s
       in
       let tails =
-        match p.optional_labels with
-        | [] -> tails
-        | _ ->
-          Ext_list.filter_map tails (fun (f, x) ->
-              match x.expression_desc with
-              | Undefined _ when is_optional f -> None
-              | _ -> Some (f, x))
+        Ext_list.filter_map tails (fun ((f, optional), x) ->
+            match x.expression_desc with
+            | Undefined _ when optional -> None
+            | _ -> Some (f, x))
       in
       if untagged then tails
       else

compiler/core/js_pass_flatten_and_mark_dead.ml

@@ -207,9 +207,8 @@ let subst_map (substitution : J.expression Hash_ident.t) =
                         match Ext_list.nth_opt fields i with
                         | None -> Printf.sprintf "%d" i
                         | Some x -> x)
-                      | Blk_record {fields} ->
-                        Ext_array.get_or fields i (fun _ ->
-                            Printf.sprintf "%d" i)
+                      | Blk_record {fields} -> (
+                        try fst fields.(i) with _ -> Printf.sprintf "%d" i)
                       | _ -> Printf.sprintf "%d" i)
                   in
                   (i + 1, E.var match_id :: e, (match_id, v') :: acc))

compiler/core/lam_compile.ml

@@ -425,9 +425,9 @@ let compile output_prefix =
                  S.exp
                    (Js_of_lam_block.set_field
                       (match tag_info with
-                      | Blk_record {fields = xs} -> Fld_record_set xs.(i)
+                      | Blk_record {fields = xs} -> Fld_record_set (fst xs.(i))
                       | Blk_record_inlined xs ->
-                        Fld_record_inline_set xs.fields.(i)
+                        Fld_record_inline_set (fst xs.fields.(i))
                       | Blk_constructor p -> (
                         let is_cons = p.name = Literals.cons in
                         match (is_cons, i) with

compiler/core/lam_convert.ml

@@ -34,9 +34,8 @@ let lam_extension_id loc (head : Lam.t) =
 let lazy_block_info : Lam_tag_info.t =
   Blk_record
     {
-      fields = [|Literals.lazy_done; Literals.lazy_val|];
+      fields = [|(Literals.lazy_done, false); (Literals.lazy_val, false)|];
       mutable_flag = Mutable;
-      record_repr = Record_regular;
     }
 
 (** A conservative approach to avoid packing exceptions

compiler/core/lam_util.ml

@@ -198,7 +198,7 @@ let field_flatten_get
       | Fld_record {name} ->
         let found = ref None in
         for i = 0 to Array.length fields - 1 do
-          if fields.(i) = name then found := Ext_list.nth_opt ls i done;
+          if fst(fields.(i)) = name then found := Ext_list.nth_opt ls i done;
         (match !found with
         | Some c -> Lam.const c
         | None  -> lam())

compiler/gentype/TranslateSignatureFromTypes.ml

@@ -12,9 +12,8 @@ let translate_type_declaration_from_types ~config ~output_file_relative
     Log_.item "Translate Types.type_declaration %s\n" type_name;
   let declaration_kind =
     match type_kind with
-    | Type_record (label_declarations, record_representation) ->
-      TranslateTypeDeclarations.RecordDeclarationFromTypes
-        (label_declarations, record_representation)
+    | Type_record (label_declarations, _) ->
+      TranslateTypeDeclarations.RecordDeclarationFromTypes label_declarations
     | Type_variant constructor_declarations
       when not
              (TranslateTypeDeclarations.has_some_gadt_leaf

compiler/gentype/TranslateTypeDeclarations.ml

@@ -1,8 +1,7 @@
 open GenTypeCommon
 
 type declaration_kind =
-  | RecordDeclarationFromTypes of
-      Types.label_declaration list * Types.record_representation
+  | RecordDeclarationFromTypes of Types.label_declaration list
   | GeneralDeclaration of Typedtree.core_type option
   | GeneralDeclarationFromTypes of Types.type_expr option
       (** As the above, but from Types not Typedtree *)
@@ -86,16 +85,12 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver
     in
     {CodeItem.import_types; export_from_type_declaration}
   in
-  let translate_label_declarations ?(inline = false) ~record_representation
-      label_declarations =
-    let is_optional l =
-      match record_representation with
-      | Types.Record_optional_labels lbls -> List.mem l lbls
-      | _ -> false
-    in
+  let translate_label_declarations ?(inline = false) label_declarations =
     let field_translations =
       label_declarations
-      |> List.map (fun {Types.ld_id; ld_mutable; ld_type; ld_attributes} ->
+      |> List.map
+           (fun
+             {Types.ld_id; ld_mutable; ld_optional; ld_type; ld_attributes} ->
              let name =
                rename_record_field ~attributes:ld_attributes
                  ~name:(ld_id |> Ident.name)
@@ -107,25 +102,32 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver
              in
              ( name,
                mutability,
+               ld_optional,
                ld_type
                |> TranslateTypeExprFromTypes.translate_type_expr_from_types
                     ~config ~type_env,
                Annotation.doc_string_from_attrs ld_attributes ))
     in
     let dependencies =
       field_translations
-      |> List.map (fun (_, _, {TranslateTypeExprFromTypes.dependencies}, _) ->
+      |> List.map
+           (fun (_, _, _, {TranslateTypeExprFromTypes.dependencies}, _) ->
              dependencies)
       |> List.concat
     in
     let fields =
       field_translations
       |> List.map
            (fun
-             (name, mutable_, {TranslateTypeExprFromTypes.type_}, doc_string) ->
+             ( name,
+               mutable_,
+               optional_,
+               {TranslateTypeExprFromTypes.type_},
+               doc_string )
+           ->
              let optional, type1 =
                match type_ with
-               | Option type1 when is_optional name -> (Optional, type1)
+               | Option type1 when optional_ -> (Optional, type1)
                | _ -> (Mandatory, type_)
              in
              {mutable_; name_js = name; optional; type_ = type1; doc_string})
@@ -216,10 +218,9 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver
     in
     {translation with type_} |> handle_general_declaration
     |> return_type_declaration
-  | RecordDeclarationFromTypes (label_declarations, record_representation), None
-    ->
+  | RecordDeclarationFromTypes label_declarations, None ->
     let {TranslateTypeExprFromTypes.dependencies; type_} =
-      label_declarations |> translate_label_declarations ~record_representation
+      label_declarations |> translate_label_declarations
     in
     let import_types =
       dependencies
@@ -250,8 +251,7 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver
                | Cstr_record label_declarations ->
                  [
                    label_declarations
-                   |> translate_label_declarations ~inline:true
-                        ~record_representation:Types.Record_regular;
+                   |> translate_label_declarations ~inline:true;
                  ]
              in
              let arg_types =
@@ -334,8 +334,8 @@ let translate_type_declaration ~config ~output_file_relative ~resolver ~type_env
   in
   let declaration_kind =
     match typ_type.type_kind with
-    | Type_record (label_declarations, record_representation) ->
-      RecordDeclarationFromTypes (label_declarations, record_representation)
+    | Type_record (label_declarations, _) ->
+      RecordDeclarationFromTypes label_declarations
     | Type_variant constructor_declarations ->
       VariantDeclarationFromTypes constructor_declarations
     | Type_abstract -> GeneralDeclaration typ_manifest

compiler/ml/ctype.ml

@@ -3721,8 +3721,7 @@ let rec subtype_rec env trace t1 t2 cstrs =
             (_, _, {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
@@ -3731,7 +3730,7 @@ let rec subtype_rec env trace t1 t2 cstrs =
           in
           if same_repr then
             let violation, tl1, tl2 =
-              Record_coercion.check_record_fields ~repr1 ~repr2 fields1 fields2
+              Record_coercion.check_record_fields fields1 fields2
             in
             if violation then (trace, t1, t2, !univar_pairs) :: cstrs
             else subtype_list env trace tl1 tl2 cstrs

compiler/ml/datarepr.ml

@@ -128,13 +128,6 @@ let constructor_descrs ty_path decl cstrs =
             describe_constructors idx_const (idx_nonconst + 1) rem )
       in
       let cstr_name = Ident.name cd_id in
-      let optional_labels =
-        match cd_args with
-        | Cstr_tuple _ -> []
-        | Cstr_record lbls ->
-          Ext_list.filter_map lbls (fun {ld_id; ld_optional} ->
-              if ld_optional then Some ld_id.name else None)
-      in
       let existentials, cstr_args, cstr_inlined =
         let representation =
           if decl.type_unboxed.unboxed then Record_unboxed true
@@ -144,7 +137,6 @@ let constructor_descrs ty_path decl cstrs =
                 tag = idx_nonconst;
                 name = cstr_name;
                 num_nonconsts = !num_nonconsts;
-                optional_labels;
                 attrs = cd_attributes;
               }
         in
@@ -232,6 +224,7 @@ let dummy_label =
     lbl_res = none;
     lbl_arg = none;
     lbl_mut = Immutable;
+    lbl_optional = false;
     lbl_pos = -1;
     lbl_all = [||];
     lbl_repres = Record_regular;
@@ -251,6 +244,7 @@ let label_descrs ty_res lbls repres priv =
           lbl_res = ty_res;
           lbl_arg = l.ld_type;
           lbl_mut = l.ld_mutable;
+          lbl_optional = l.ld_optional;
           lbl_pos = num;
           lbl_all = all_labels;
           lbl_repres = repres;

compiler/ml/includecore.ml

@@ -147,6 +147,7 @@ type type_mismatch =
   | Variance
   | Field_type of Ident.t
   | Field_mutable of Ident.t
+  | Field_optional of Ident.t
   | Field_arity of Ident.t
   | Field_names of int * string * string
   | Field_missing of bool * Ident.t
@@ -168,28 +169,17 @@ let report_type_mismatch0 first second decl ppf err =
   | Field_type s -> pr "The types for field %s are not equal" (Ident.name s)
   | Field_mutable s ->
     pr "The mutability of field %s is different" (Ident.name s)
+  | Field_optional s ->
+    pr "The optional attribute of field %s is different" (Ident.name s)
   | Field_arity s -> pr "The arities for field %s differ" (Ident.name s)
   | Field_names (n, name1, name2) ->
     pr "Fields number %i have different names, %s and %s" n name1 name2
   | Field_missing (b, s) ->
     pr "The field %s is only present in %s %s" (Ident.name s)
       (if b then second else first)
       decl
-  | Record_representation (rep1, rep2) -> (
-    let default () = pr "Their internal representations differ" in
-    match (rep1, rep2) with
-    | Record_optional_labels lbls1, Record_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 =
-        Ext_list.find_first lbls2 (fun l -> not (Ext_list.mem_string lbls1 l))
-      in
-      match (only_in_lhs, only_in_rhs) with
-      | Some l, _ -> pr "@optional label %s only in %s" l second
-      | _, Some l -> pr "@optional label %s only in %s" l first
-      | None, None -> default ())
-    | _ -> default ())
+  | Record_representation (_rep1, _rep2) ->
+    pr "Their internal representations differ"
   | Unboxed_representation b ->
     pr "Their internal representations differ:@ %s %s %s"
       (if b then second else first)
@@ -280,6 +270,7 @@ and compare_records ~loc env params1_ params2_ n_
       if Ident.name ld1.ld_id <> Ident.name ld2.ld_id then
         [Field_names (n, ld1.ld_id.name, ld2.ld_id.name)]
       else if ld1.ld_mutable <> ld2.ld_mutable then [Field_mutable ld1.ld_id]
+      else if ld1.ld_optional <> ld2.ld_optional then [Field_optional ld1.ld_id]
       else (
         Builtin_attributes.check_deprecated_mutable_inclusion ~def:ld1.ld_loc
           ~use:ld2.ld_loc loc ld1.ld_attributes ld2.ld_attributes

compiler/ml/includecore.mli

@@ -29,6 +29,7 @@ type type_mismatch =
   | Variance
   | Field_type of Ident.t
   | Field_mutable of Ident.t
+  | Field_optional of Ident.t
   | Field_arity of Ident.t
   | Field_names of int * string * string
   | Field_missing of bool * Ident.t