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"
@@ -174,13 +169,9 @@ let printSignature ~extractor ~signature =
                 labelDecl.ld_type
             in
             let lblName = labelDecl.ld_id |> Ident.name in
+            let _ = 10 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

@@ -794,28 +794,23 @@ 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 is_optional (pname : Js_op.property_name) =
+           match pname with
+           | Lit n -> Ext_list.mem_string p.optional_labels n
+           | Symbol_name -> false
+         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/lam_compile.ml

@@ -427,7 +427,7 @@ let compile output_prefix =
                       (match tag_info with
                       | Blk_record {fields = xs} -> Fld_record_set 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/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,8 @@ 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_optional_labels),
+                (Record_regular | Record_optional_labels) ) ->
               true (* handled in the fields checks *)
             | Record_unboxed b1, Record_unboxed b2 -> b1 = b2
             | Record_inlined _, Record_inlined _ -> repr1 = repr2
@@ -3731,7 +3731,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

compiler/ml/lambda.ml

@@ -28,8 +28,7 @@ type tag_info =
       name: string;
       num_nonconst: int;
       tag: int;
-      optional_labels: string list;
-      fields: string array;
+      fields: (string * bool (* optional *)) array;
       mutable_flag: Asttypes.mutable_flag;
       attrs: Parsetree.attributes;
     }
@@ -104,16 +103,15 @@ let blk_record_ext fields mutable_flag =
   in
   Blk_record_ext {fields = all_labels_info; mutable_flag}
 
-let blk_record_inlined fields name num_nonconst optional_labels ~tag ~attrs
-    mutable_flag =
+let blk_record_inlined fields name num_nonconst ~tag ~attrs mutable_flag =
   let fields =
     Array.map
       (fun ((lbl : label), _) ->
-        Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name)
+        ( Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name,
+          lbl.lbl_optional ))
       fields
   in
-  Blk_record_inlined
-    {fields; name; num_nonconst; tag; mutable_flag; optional_labels; attrs}
+  Blk_record_inlined {fields; name; num_nonconst; tag; mutable_flag; attrs}
 
 let ref_tag_info : tag_info =
   Blk_record

compiler/ml/lambda.mli

@@ -32,8 +32,7 @@ type tag_info =
       name: string;
       num_nonconst: int;
       tag: int;
-      optional_labels: string list;
-      fields: string array;
+      fields: (string * bool (* optional *)) array;
       mutable_flag: mutable_flag;
       attrs: Parsetree.attributes;
     }
@@ -81,7 +80,6 @@ val blk_record_inlined :
   (Types.label_description * Typedtree.record_label_definition) array ->
   string ->
   int ->
-  string list ->
   tag:int ->
   attrs:Parsetree.attributes ->
   mutable_flag ->

compiler/ml/matching.ml

@@ -1530,7 +1530,7 @@ let make_record_matching loc all_labels def = function
         let access =
           match lbl.lbl_repres with
           | Record_float_unused -> assert false
-          | Record_regular | Record_optional_labels _ ->
+          | Record_regular | Record_optional_labels ->
             Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [arg], loc)
           | Record_inlined _ ->
             Lprim

compiler/ml/parmatch.ml

@@ -526,24 +526,19 @@ let all_record_args lbls =
     in
     List.iter
       (fun ((id, lbl, pat) as x) ->
-        let lbl_is_optional () =
-          match lbl.lbl_repres with
-          | Record_optional_labels labels -> List.mem lbl.lbl_name labels
-          | _ -> false
-        in
         let x =
           match pat.pat_desc with
           | Tpat_construct
               ( {txt = Longident.Ldot (Longident.Lident "*predef*", "Some")},
                 _,
                 [({pat_desc = Tpat_constant _} as c)] )
-            when lbl_is_optional () ->
+            when lbl.lbl_optional ->
             (id, lbl, c)
           | Tpat_construct
               ( {txt = Longident.Ldot (Longident.Lident "*predef*", "Some")},
                 _,
                 [({pat_desc = Tpat_construct (_, cd, _)} as pat_construct)] )
-            when lbl_is_optional () -> (
+            when lbl.lbl_optional -> (
             let cdecl =
               Ast_untagged_variants
               .constructor_declaration_from_constructor_description