Add support for @optional in record declarations and remove @obj.

Changes.md

@@ -4,7 +4,8 @@
 
 **Compiler**
 
-- #5364 support `@new @variadic`
+- Added support for `@new @variadic` (see https://github.com/rescript-lang/rescript-compiler/pull/5364) 
+- Added support for `@optional` fields in records (see https://github.com/rescript-lang/rescript-compiler/pull/5423)
 
 **Syntax**
 

jscomp/core/js_dump.ml

@@ -718,7 +718,7 @@ and expression_desc cxt ~(level : int) f x : cxt =
         | Record_regular ->
             expression_desc cxt ~level f
               (Object (Ext_list.combine_array fields el (fun i -> Js_op.Lit i)))
-        | Record_object ->
+        | Record_optional ->
             let fields =
               Ext_list.array_list_filter_map fields el (fun f x ->
                   match x.expression_desc with

jscomp/dune

@@ -50,7 +50,7 @@
 
 (library
  (name jscomp)
- (flags "-w" "+26+27+32+33+39-deprecated")
+ (flags "-w" "+26+27+32+33+39-d")
  ; Depends on:
  (libraries unix str)
  (modules_without_implementation

jscomp/ml/includecore.ml

@@ -136,7 +136,7 @@ type type_mismatch =
   | Field_arity of Ident.t
   | Field_names of int * string * string
   | Field_missing of bool * Ident.t
-  | Record_representation of bool   (* true means second one is unboxed float *)
+  | Record_representation of record_representation * record_representation
   | Unboxed_representation of bool  (* true means second one is unboxed *)
   | Immediate
 
@@ -161,10 +161,23 @@ let report_type_mismatch0 first second decl ppf err =
   | 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 b ->
-      pr "Their internal representations differ:@ %s %s %s"
-        (if b then second else first) decl
-        "uses @@obj representation"
+  | 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 onlyInLhs =
+            Ext_list.find_first lbls1 (fun l -> not (Ext_list.mem_string lbls2 l)) in
+          let onlyInRhs =
+            Ext_list.find_first lbls2 (fun l -> not (Ext_list.mem_string lbls1 l)) in
+          (match onlyInLhs, onlyInRhs 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 ()
+      )
   | Unboxed_representation b ->
       pr "Their internal representations differ:@ %s %s %s"
          (if b then second else first) decl
@@ -314,7 +327,7 @@ let type_declarations ?(equality = false) ~loc env name decl1 id decl2 =
         let err = compare_records ~loc env decl1.type_params decl2.type_params
             1 labels1 labels2 in
         if err <> [] || rep1 = rep2 then err else
-        [Record_representation (rep2 = Record_object)]
+        [Record_representation (rep1, rep2)]
     | (Type_open, Type_open) -> []
     | (_, _) -> [Kind]
   in

jscomp/ml/includecore.mli

@@ -32,7 +32,7 @@ type type_mismatch =
   | Field_arity of Ident.t
   | Field_names of int * string * string
   | Field_missing of bool * Ident.t
-  | Record_representation of bool
+  | Record_representation of record_representation * record_representation
   | Unboxed_representation of bool
   | Immediate
 

jscomp/ml/lambda.ml

@@ -35,8 +35,8 @@ type loc_kind =
   | Loc_POS
 
 type record_repr = 
-  | Record_regular 
-  | Record_object 
+  | Record_regular
+  | Record_optional
 
 type tag_info = 
   | Blk_constructor of {name : string ; num_nonconst : int ; tag : int }

jscomp/ml/lambda.mli

@@ -36,7 +36,7 @@ type loc_kind =
 
 type record_repr = 
   | Record_regular 
-  | Record_object 
+  | Record_optional
 
 type tag_info = 
   | Blk_constructor of {name : string ; num_nonconst : int; tag : int}

jscomp/ml/matching.ml

@@ -1596,7 +1596,8 @@ let make_record_matching loc all_labels def = function
           let lbl = all_labels.(pos) in
           let access =
             match lbl.lbl_repres with
-            | Record_regular | Record_object -> 
+            | Record_float_unused -> assert false
+            | Record_regular | Record_optional_labels _ -> 
               Lprim (Pfield (lbl.lbl_pos, !Lambda.fld_record lbl), [arg], loc) 
             | Record_inlined _ ->
               Lprim (Pfield (lbl.lbl_pos, Fld_record_inline {name = lbl.lbl_name}), [arg], loc)

jscomp/ml/oprint.ml

@@ -616,9 +616,6 @@ and print_out_type_decl kwd ppf td =
   let print_unboxed ppf =
     if td.otype_unboxed then fprintf ppf " [%@%@unboxed]" else ()
   in
-  let print_record_obj ppf = 
-    if td.otype_record_obj then fprintf ppf " [%@%@obj]"
-  in 
   let print_out_tkind ppf = function
   | Otyp_abstract -> ()
   | Otyp_record lbls ->
@@ -637,13 +634,12 @@ and print_out_type_decl kwd ppf td =
         print_private td.otype_private
         !out_type ty
   in
-  fprintf ppf "@[<2>@[<hv 2>%t%a@]%t%t%t%t@]"
+  fprintf ppf "@[<2>@[<hv 2>%t%a@]%t%t%t@]"
     print_name_params
     print_out_tkind ty
     print_constraints
     print_immediate
     print_unboxed
-    print_record_obj
 
 and print_out_constr ppf (name, tyl,ret_type_opt) =
   let name =

jscomp/ml/outcometree.ml

@@ -111,7 +111,6 @@ and out_type_decl =
     otype_private: Asttypes.private_flag;
     otype_immediate: bool;
     otype_unboxed: bool;
-    otype_record_obj : bool;
     otype_cstrs: (out_type * out_type) list }
 and out_extension_constructor =
   { oext_name: string;

jscomp/ml/printtyp.ml

@@ -878,7 +878,6 @@ let rec tree_of_type_decl id decl =
   in
   let (name, args) = type_defined decl in
   let constraints = tree_of_constraints params in
-  let otype_record_obj = ref false in 
   let ty, priv =
     match decl.type_kind with
     | Type_abstract ->
@@ -890,8 +889,7 @@ let rec tree_of_type_decl id decl =
     | Type_variant cstrs ->
         tree_of_manifest (Otyp_sum (List.map tree_of_constructor cstrs)),
         decl.type_private
-    | Type_record(lbls, rep) ->
-        if rep = Record_object then otype_record_obj := true; 
+    | Type_record(lbls, _rep) ->
         tree_of_manifest (Otyp_record (List.map tree_of_label lbls)),
         decl.type_private
     | Type_open ->
@@ -908,7 +906,6 @@ let rec tree_of_type_decl id decl =
       otype_immediate = immediate;
       otype_unboxed = decl.type_unboxed.unboxed;
       otype_cstrs = constraints ;
-      otype_record_obj = !otype_record_obj
       }
 
 and tree_of_constructor_arguments = function

jscomp/ml/printtyped.ml

@@ -151,7 +151,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_object -> line i ppf "Record_object\n"
+  | Record_float_unused -> assert false
+  | Record_optional_labels lbls ->
+    line i ppf "Record_optional_labels %s\n" (lbls |> 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"

jscomp/ml/rec_check.ml

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

jscomp/ml/translcore.ml

@@ -848,7 +848,8 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda =
   | Texp_field (arg, _, lbl) -> (
       let targ = transl_exp arg in
       match lbl.lbl_repres with
-      | Record_regular | Record_object ->
+      | Record_float_unused -> assert false
+      | Record_regular | Record_optional_labels _ ->
           Lprim
             (Pfield (lbl.lbl_pos, !Lambda.fld_record lbl), [ targ ], e.exp_loc)
       | Record_inlined _ ->
@@ -866,7 +867,8 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda =
   | Texp_setfield (arg, _, lbl, newval) ->
       let access =
         match lbl.lbl_repres with
-        | Record_regular | Record_object ->
+        | Record_float_unused -> assert false
+        | Record_regular | Record_optional_labels _ ->
             Psetfield (lbl.lbl_pos, !Lambda.fld_record_set lbl)
         | Record_inlined _ ->
             Psetfield (lbl.lbl_pos, Fld_record_inline_set lbl.lbl_name)
@@ -1088,7 +1090,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 && repres <> Record_object)
+        no_init || (size < 20 && (match repres with Record_optional_labels _ -> false | _ -> true))
         (* TODO: More strategies
            3 + 2 * List.length lbl_expr_list >= size (density)
         *)
@@ -1103,7 +1105,8 @@ and transl_record loc env fields repres opt_init_expr =
               | Kept _ ->
                   let access =
                     match repres with
-                    | Record_regular | Record_object ->
+                    | Record_float_unused -> assert false
+                    | Record_regular | Record_optional_labels _ ->
                         Pfield (i, !Lambda.fld_record lbl)
                     | Record_inlined _ ->
                         Pfield (i, Fld_record_inline { name = lbl.lbl_name })
@@ -1127,12 +1130,13 @@ 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_object ->
-                Lconst
-                  (Const_block (!Lambda.blk_record fields mut Record_object, cl))
+            | Record_float_unused -> assert false
             | Record_regular ->
                 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))
             | Record_inlined { tag; name; num_nonconsts } ->
                 Lconst
                   (Const_block
@@ -1149,11 +1153,12 @@ and transl_record loc env fields repres opt_init_expr =
                   ( Pmakeblock (!Lambda.blk_record fields mut Record_regular),
                     ll,
                     loc )
-            | Record_object ->
+            | Record_optional_labels _ ->
                 Lprim
-                  ( Pmakeblock (!Lambda.blk_record fields mut Record_object),
+                  ( Pmakeblock (!Lambda.blk_record fields mut Record_optional),
                     ll,
                     loc )
+            | Record_float_unused -> assert false
             | Record_inlined { tag; name; num_nonconsts } ->
                 Lprim
                   ( Pmakeblock
@@ -1190,7 +1195,8 @@ and transl_record loc env fields repres opt_init_expr =
           | Overridden (_lid, expr) ->
               let upd =
                 match repres with
-                | Record_object | Record_regular ->
+                | Record_float_unused -> assert false
+                | Record_regular | Record_optional_labels _ ->
                     Psetfield (lbl.lbl_pos, !Lambda.fld_record_set lbl)
                 | Record_inlined _ ->
                     Psetfield (lbl.lbl_pos, Fld_record_inline_set lbl.lbl_name)

jscomp/ml/typecore.ml

@@ -296,14 +296,6 @@ let extract_option_type env ty =
     when Path.same path Predef.path_option -> ty
   | _ -> assert false
 
-let is_option_type env ty = 
-  match expand_head env ty with 
-  | {desc = Tconstr(path, [_], _)}
-    when Path.same path Predef.path_option -> true 
-  | _ -> false 
-  | exception _ -> false
-
-
 let extract_concrete_record env ty =
   match extract_concrete_typedecl env ty with
     (p0, p, {type_kind=Type_record (fields, _)}) -> (p0, p, fields)
@@ -1864,6 +1856,19 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
     unify_exp env (re exp) (instance env ty_expected);
     exp
   in
+  let label_is_optional ld =
+    match ld.lbl_repres with
+    | Record_optional_labels lbls -> Ext_list.mem_string lbls ld.lbl_name
+    | _ -> false in
+  let process_optional_label (id, ld, e) =
+    let exp_optional_attr =
+      Ext_list.exists e.pexp_attributes (fun ({txt },_) -> txt = "optional")
+    in
+    if label_is_optional ld && not exp_optional_attr then
+      let pexp_desc = Pexp_construct ({id with txt = Longident.Lident "Some"}, Some e)
+      in (id, ld, {e with pexp_desc})
+    else (id, ld, e)
+  in
   match sexp.pexp_desc with
   | Pexp_ident lid ->
       begin
@@ -2100,7 +2105,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
         let lbl_exp_list =
           wrap_disambiguate "This record expression is expected to have" ty_record
             (type_label_a_list loc true env
-               (fun e k -> k (type_label_exp true env loc ty_record e))
+               (fun e k -> k (type_label_exp true env loc ty_record (process_optional_label e)))
                opath lid_sexp_list)
             (fun x -> x)
         in
@@ -2119,8 +2124,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
                     | (lid, _lbl, lbl_exp) ->
                         Overridden (lid, lbl_exp)
                     | exception Not_found ->
-                      if  representation = Record_object 
-                          && is_option_type env lbl.lbl_arg then 
+                      if label_is_optional lbl then 
                         Overridden ({loc ; txt = Lident lbl.lbl_name},
                         option_none lbl.lbl_arg loc)
                       else 
@@ -2171,7 +2175,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
       let lbl_exp_list =
         wrap_disambiguate "This record expression is expected to have" ty_record
           (type_label_a_list loc closed env
-             (fun e k -> k (type_label_exp true env loc ty_record e))
+             (fun e k -> k (type_label_exp true env loc ty_record (process_optional_label e)))
              opath lid_sexp_list)
           (fun x -> x)
       in

jscomp/ml/typedecl.ml

@@ -396,11 +396,25 @@ let transl_declaration env sdecl id =
         let tcstrs, cstrs = List.split (List.map make_cstr scstrs) in
           Ttype_variant tcstrs, Type_variant cstrs
       | Ptype_record lbls ->
+          let has_optional attrs = Ext_list.exists attrs (fun ({txt },_) -> txt = "optional") in
+          let optionalLabels =
+              Ext_list.filter_map lbls
+              (fun lbl -> if has_optional lbl.pld_attributes then Some lbl.pld_name.txt else None) in
+          let lbls =
+            if optionalLabels = [] then lbls
+            else Ext_list.map lbls (fun lbl ->
+              let typ = lbl.pld_type in
+              let typ =
+                if has_optional lbl.pld_attributes then
+                  {typ with ptyp_desc = Ptyp_constr ({txt = Lident "option"; loc=typ.ptyp_loc}, [typ])}
+                else typ in
+              {lbl with  pld_type = typ }) in
           let lbls, lbls' = transl_labels env true lbls in
           let rep =
             if unbox then Record_unboxed false
             else 
-              if Ext_list.exists sdecl.ptype_attributes (fun ({txt },_) -> txt = "obj") then Record_object
+              if optionalLabels <> []
+              then Record_optional_labels optionalLabels
               else Record_regular
           in
           Ttype_record lbls, Type_record(lbls', rep)

jscomp/ml/types.ml

@@ -150,11 +150,13 @@ and type_kind =
   | Type_open
 
 and record_representation =
-    Record_regular                      (* All fields are boxed / tagged *)
-  | Record_object                       (* None fileds can be omitted *)
-  | Record_unboxed of bool    (* Unboxed single-field record, inlined or not *)
-  | Record_inlined of {tag : int; name : string; num_nonconsts : int}               (* Inlined record *)
-  | Record_extension                    (* Inlined record under extension *)
+  | Record_regular                        (* All fields are boxed / tagged *)
+  | Record_float_unused                   (* Was: all fields are floats. Now: unused *)
+  | Record_unboxed of bool                (* Unboxed single-field record, inlined or not *)
+  | Record_inlined of                     (* Inlined record *)
+      { tag : int ; name : string; num_nonconsts : int}
+  | Record_extension                      (* Inlined record under extension *)
+  | Record_optional_labels of string list (* List of optional labels *)
 
 and label_declaration =
   {
@@ -341,7 +343,11 @@ type label_description =
 let same_record_representation x y =
   match x with
   | Record_regular -> y = Record_regular
-  | Record_object -> y = Record_object
+  | Record_float_unused -> y = Record_float_unused
+  | Record_optional_labels lbls -> (
+      match y with
+      | Record_optional_labels lbls2 -> lbls = lbls2
+      | _ -> false)
   | Record_inlined {tag; name; num_nonconsts} -> (
       match y with
       | Record_inlined y ->