Clean up Record_optional_labels

Clean up Record_optional_labels: determine whether a field is optional directly.

Author: cristianoc

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/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/ast_mapper_to0.ml

@@ -468,7 +468,8 @@ let default_mapper =
           ~mut:pld_mutable
           ~loc:(this.location this pld_loc)
           ~attrs:
-            (Parsetree0.add_optional_attr ~optional:pld_optional (this.attributes this pld_attributes)));
+            (Parsetree0.add_optional_attr ~optional:pld_optional
+               (this.attributes this pld_attributes)));
     cases = (fun this l -> List.map (this.case this) l);
     case =
       (fun this {pc_lhs; pc_guard; pc_rhs} ->

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

@@ -232,6 +232,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 +252,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/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

compiler/ml/predef.ml

@@ -316,7 +316,7 @@ let common_initial_env add_type add_extension empty_env =
                 ld_type = newgenty (Tconstr (path_option, [tvar], ref Mnil));
               };
             ],
-            Record_optional_labels [Ident.name ident_dict_magic_field_name] );
+            Record_optional_labels );
     }
   and decl_uncurried =
     let tvar1, tvar2 = (newgenvar (), newgenvar ()) in

compiler/ml/printtyped.ml

@@ -130,8 +130,7 @@ let record_representation i ppf =
   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_optional_labels -> line i ppf "Record_optional_labels\n"
   | 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"

compiler/ml/rec_check.ml

@@ -261,7 +261,7 @@ let rec expression : Env.env -> Typedtree.expression -> Use.t =
       match rep with
       | Record_unboxed _ -> fun x -> x
       | Record_float_unused -> assert false
-      | Record_optional_labels _ | Record_regular | Record_inlined _
+      | Record_optional_labels | Record_regular | Record_inlined _
       | Record_extension ->
         Use.guard
     in

compiler/ml/record_coercion.ml

@@ -1,18 +1,13 @@
-let check_record_fields ?repr1 ?repr2 (fields1 : Types.label_declaration list)
+let check_record_fields (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
-    | _ -> false
-  in
   let violation = ref false in
   let label_decl_sub (acc1, acc2) (ld2 : Types.label_declaration) =
     match
       Ext_list.find_first fields1 (fun ld1 -> ld1.ld_id.name = ld2.ld_id.name)
     with
     | Some ld1 ->
-      if field_is_optional ld1.ld_id repr1 <> field_is_optional ld2.ld_id repr2
-      then (* optional field can't be modified *)
+      if ld1.ld_optional <> ld2.ld_optional then
+        (* optional field can't be modified *)
         violation := true;
       let get_as (({txt}, payload) : Parsetree.attribute) =
         if txt = "as" then Ast_payload.is_single_string payload else None

compiler/ml/translcore.ml

@@ -923,7 +923,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda =
     let targ = transl_exp arg in
     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), [targ], e.exp_loc)
     | Record_inlined _ ->
       Lprim
@@ -938,7 +938,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda =
     let access =
       match lbl.lbl_repres with
       | Record_float_unused -> assert false
-      | Record_regular | Record_optional_labels _ ->
+      | Record_regular | Record_optional_labels ->
         Psetfield (lbl.lbl_pos, Lambda.fld_record_set lbl)
       | Record_inlined _ ->
         Psetfield (lbl.lbl_pos, Lambda.fld_record_inline_set lbl)
@@ -1171,7 +1171,7 @@ and transl_record loc env fields repres opt_init_expr =
       || size < 20
          &&
          match repres with
-         | Record_optional_labels _ -> false
+         | Record_optional_labels -> false
          | _ -> true
       (* TODO: More strategies
          3 + 2 * List.length lbl_expr_list >= size (density)
@@ -1188,7 +1188,7 @@ and transl_record loc env fields repres opt_init_expr =
               let access =
                 match repres with
                 | Record_float_unused -> assert false
-                | Record_regular | Record_optional_labels _ ->
+                | Record_regular | Record_optional_labels ->
                   Pfield (i, Lambda.fld_record lbl)
                 | Record_inlined _ -> Pfield (i, Lambda.fld_record_inline lbl)
                 | Record_unboxed _ -> assert false
@@ -1214,7 +1214,7 @@ and transl_record loc env fields repres opt_init_expr =
           | Record_regular ->
             Lconst
               (Const_block (Lambda.blk_record fields mut Record_regular, cl))
-          | Record_optional_labels _ ->
+          | Record_optional_labels ->
             Lconst
               (Const_block (Lambda.blk_record fields mut Record_optional, cl))
           | Record_inlined {tag; name; num_nonconsts; optional_labels; attrs} ->
@@ -1234,7 +1234,7 @@ and transl_record loc env fields repres opt_init_expr =
           | Record_regular ->
             Lprim
               (Pmakeblock (Lambda.blk_record fields mut Record_regular), ll, loc)
-          | Record_optional_labels _ ->
+          | Record_optional_labels ->
             Lprim
               ( Pmakeblock (Lambda.blk_record fields mut Record_optional),
                 ll,
@@ -1277,7 +1277,7 @@ and transl_record loc env fields repres opt_init_expr =
           let upd =
             match repres with
             | Record_float_unused -> assert false
-            | Record_regular | Record_optional_labels _ ->
+            | Record_regular | Record_optional_labels ->
               Psetfield (lbl.lbl_pos, Lambda.fld_record_set lbl)
             | Record_inlined _ ->
               Psetfield (lbl.lbl_pos, Lambda.fld_record_inline_set lbl)