diff --git a/Changes.md b/Changes.md index d4ff780abb..d054daf0fd 100644 --- a/Changes.md +++ b/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** diff --git a/jscomp/core/js_dump.ml b/jscomp/core/js_dump.ml index f127120bff..05f38ffcd8 100644 --- a/jscomp/core/js_dump.ml +++ b/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 diff --git a/jscomp/dune b/jscomp/dune index 769b18a4d0..66b4343525 100644 --- a/jscomp/dune +++ b/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 diff --git a/jscomp/ml/includecore.ml b/jscomp/ml/includecore.ml index f578872964..8bf9770c9d 100644 --- a/jscomp/ml/includecore.ml +++ b/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 diff --git a/jscomp/ml/includecore.mli b/jscomp/ml/includecore.mli index 4682831f8e..1f4cffc31c 100644 --- a/jscomp/ml/includecore.mli +++ b/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 diff --git a/jscomp/ml/lambda.ml b/jscomp/ml/lambda.ml index 00dde8d14d..ba0390b5ff 100644 --- a/jscomp/ml/lambda.ml +++ b/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 } diff --git a/jscomp/ml/lambda.mli b/jscomp/ml/lambda.mli index ed281bbe5c..b05f17bff2 100644 --- a/jscomp/ml/lambda.mli +++ b/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} diff --git a/jscomp/ml/matching.ml b/jscomp/ml/matching.ml index 7b82c891c3..d10d5639af 100644 --- a/jscomp/ml/matching.ml +++ b/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) diff --git a/jscomp/ml/oprint.ml b/jscomp/ml/oprint.ml index a6d4635b1d..49aa2f4b0c 100644 --- a/jscomp/ml/oprint.ml +++ b/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>@[%t%a@]%t%t%t%t@]" + fprintf ppf "@[<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 = diff --git a/jscomp/ml/outcometree.ml b/jscomp/ml/outcometree.ml index 964a9d5e63..e4c62c31f9 100644 --- a/jscomp/ml/outcometree.ml +++ b/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; diff --git a/jscomp/ml/printtyp.ml b/jscomp/ml/printtyp.ml index fde01bc81c..df788a7e09 100644 --- a/jscomp/ml/printtyp.ml +++ b/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 diff --git a/jscomp/ml/printtyped.ml b/jscomp/ml/printtyped.ml index d77587be33..09e348c9fe 100644 --- a/jscomp/ml/printtyped.ml +++ b/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" diff --git a/jscomp/ml/rec_check.ml b/jscomp/ml/rec_check.ml index ef59f8b585..71df38b2fa 100644 --- a/jscomp/ml/rec_check.ml +++ b/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 diff --git a/jscomp/ml/translcore.ml b/jscomp/ml/translcore.ml index 387c39ff51..ce1eac4156 100644 --- a/jscomp/ml/translcore.ml +++ b/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) diff --git a/jscomp/ml/typecore.ml b/jscomp/ml/typecore.ml index 34f2a2cec8..72280eae0d 100644 --- a/jscomp/ml/typecore.ml +++ b/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 diff --git a/jscomp/ml/typedecl.ml b/jscomp/ml/typedecl.ml index 4bfc0ce29e..5e9fa78458 100644 --- a/jscomp/ml/typedecl.ml +++ b/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) diff --git a/jscomp/ml/types.ml b/jscomp/ml/types.ml index bfdde3f466..f048642835 100644 --- a/jscomp/ml/types.ml +++ b/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 -> diff --git a/jscomp/ml/types.mli b/jscomp/ml/types.mli index 18eacc8982..65d0abd307 100644 --- a/jscomp/ml/types.mli +++ b/jscomp/ml/types.mli @@ -297,11 +297,13 @@ and type_kind = | Type_open and record_representation = - Record_regular (* All fields are boxed / tagged *) - | Record_object (* All fields are floats *) - | 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 = { diff --git a/jscomp/test/record_regression.js b/jscomp/test/record_regression.js index 2d67d4bfb5..e099dc2cd1 100644 --- a/jscomp/test/record_regression.js +++ b/jscomp/test/record_regression.js @@ -1,24 +1,43 @@ 'use strict'; var Caml_obj = require("../../lib/js/caml_obj.js"); +var Caml_option = require("../../lib/js/caml_option.js"); + +var f1 = { + x: 3, + z: 2 +}; + +var newrecord = Caml_obj.obj_dup(f1); + +newrecord.y = 3; + +var newrecord$1 = Caml_obj.obj_dup(newrecord); + +newrecord$1.yy = Caml_option.some(undefined); + +var theseTwoShouldBeIdentical = [ + newrecord$1.yy, + Caml_option.some(undefined) +]; var v = { x: 2, z: 3 }; -var newrecord = Caml_obj.obj_dup(v); +var newrecord$2 = Caml_obj.obj_dup(v); -newrecord.y1 = 22; +newrecord$2.y1 = 22; var v1 = { x: 2, z: 3 }; -var newrecord$1 = Caml_obj.obj_dup(v1); +var newrecord$3 = Caml_obj.obj_dup(v1); -newrecord$1.y1 = 22; +newrecord$3.y1 = 22; function h11(v1) { var newrecord = Caml_obj.obj_dup(v1); @@ -26,26 +45,52 @@ function h11(v1) { return newrecord; } -var f1 = { +var po = { + aa: 3, + bb: 4 +}; + +var newrecord$4 = Caml_obj.obj_dup(po); + +newrecord$4.aa = undefined; + +function setAA(ao) { + return { + aa: ao + }; +} + +var f2 = { x: 3, - z: 2 + y: 3, + z: 3 }; +var f3 = newrecord; + +var f4 = newrecord$1; + var v2 = { x: 3, y: undefined, z: 2 }; -var h = newrecord; +var h = newrecord$2; -var h10 = newrecord$1; +var h10 = newrecord$3; exports.f1 = f1; +exports.f2 = f2; +exports.f3 = f3; +exports.f4 = f4; +exports.theseTwoShouldBeIdentical = theseTwoShouldBeIdentical; exports.v2 = v2; exports.v = v; exports.h = h; exports.v1 = v1; exports.h10 = h10; exports.h11 = h11; +exports.po = po; +exports.setAA = setAA; /* Not a pure module */ diff --git a/jscomp/test/record_regression.res b/jscomp/test/record_regression.res index 0536f4cc0d..70bb5ca430 100644 --- a/jscomp/test/record_regression.res +++ b/jscomp/test/record_regression.res @@ -1,12 +1,17 @@ // @@config({flags: ["-bs-diagnose"] }) -@obj -type t0 = {x: int, y: option, z: int} - -// let f0 = { x : 3 ,y : None} +type t0 = {x: int, @optional y: int, @optional yy: option, z: int} let f1 = {x: 3, z: 2} +let f2 = {x: 3, z: 3, y: 3} + +let f3 = {...f1, y: 3} + +let f4 = {...f3, yy: None} + +let theseTwoShouldBeIdentical = [f4.yy, (Some(None): option>)] + type r = { x: int, y: option, @@ -24,52 +29,74 @@ let v1: t0 = { let v2: r = {x: 3, y: None, z: 2} -@obj type config = { x: int, - y0: option, - y1: option, - y2: option, - y3: option, - y4: option, - y5: option, - y6: option, - y7: option, - y8: option, - y9: option, - y10: option, - y11: option, - y12: option, - y13: option, - y14: option, - y15: option, - y16: option, - y17: option, - y18: option, - y19: option, - y20: option, - y21: option, - y22: option, - y23: option, + @optional y0: int, + @optional y1: int, + @optional y2: int, + @optional y3: int, + @optional y4: int, + @optional y5: int, + @optional y6: int, + @optional y7: int, + @optional y8: int, + @optional y9: int, + @optional y10: int, + @optional y11: int, + @optional y12: int, + @optional y13: int, + @optional y14: int, + @optional y15: int, + @optional y16: int, + @optional y17: int, + @optional y18: int, + @optional y19: int, + @optional y20: int, + @optional y21: int, + @optional y22: int, + @optional y23: int, z: int, } let v: config = {x: 2, z: 3} -let h: config = {...v, y1: Some(22)} +let h: config = {...v, y1: 22} -@obj type small_config = { x: int, - y0: option, - y1: option, + @optional y0: int, + @optional y1: int, z: int, } let v1: small_config = {x: 2, z: 3} -let h10: small_config = {...v1, y1: Some(22)} +let h10: small_config = {...v1, y1: 22} + +let h11 = (v1): small_config => { + {...v1, y1: 22} +} + +type partiallyOptional = { + @optional aa: int, + bb: option, +} + +let po = {aa: 3, bb: Some(4)} + +let _ = {...po, aa: @optional None} + +let setAA = (ao: option) => {aa: @optional ao, bb: None} -let h11 = (v1) : small_config => { - { ... v1, y1 : Some(22)} -} \ No newline at end of file +// Trigger representation mismatch error. +// module M: { +// type partiallyOptional = { +// @optional aa: int, +// bb: option, +// } +// } = { +// type partiallyOptional = { +// @optional aa: int, +// @optional bb: int, +// } +// } diff --git a/jscomp/test/res_debug.res b/jscomp/test/res_debug.res index 84f9027dba..bc7e788ada 100644 --- a/jscomp/test/res_debug.res +++ b/jscomp/test/res_debug.res @@ -27,10 +27,9 @@ let f = (window, a, b) => { // } -@obj type r = { x: int, - y: option < int>, + @optional y: int, z : int } diff --git a/lib/4.06.1/unstable/js_compiler.ml b/lib/4.06.1/unstable/js_compiler.ml index 5a31479ca2..316f7b8107 100644 --- a/lib/4.06.1/unstable/js_compiler.ml +++ b/lib/4.06.1/unstable/js_compiler.ml @@ -5092,7 +5092,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; @@ -5598,11 +5597,13 @@ and type_kind = | Type_open and record_representation = - Record_regular (* All fields are boxed / tagged *) - | Record_object (* All fields are floats *) - | 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 = { @@ -5941,11 +5942,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 = { @@ -6132,7 +6135,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 -> @@ -23706,7 +23713,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} @@ -24100,8 +24107,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 } @@ -32166,9 +32173,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 -> @@ -32187,13 +32191,12 @@ and print_out_type_decl kwd ppf td = print_private td.otype_private !out_type ty in - fprintf ppf "@[<2>@[%t%a@]%t%t%t%t@]" + fprintf ppf "@[<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 = @@ -33312,7 +33315,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 -> @@ -33324,8 +33326,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 -> @@ -33342,7 +33343,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 @@ -34165,7 +34165,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 @@ -34331,7 +34331,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 @@ -34356,10 +34356,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 @@ -34509,7 +34522,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 @@ -36176,11 +36189,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 hasOptional attrs = Ext_list.exists attrs (fun ({txt },_) -> txt = "optional") in + let optionalLabels = + Ext_list.filter_map lbls + (fun lbl -> if hasOptional 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 hasOptional 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) @@ -38258,7 +38285,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 @@ -39171,14 +39199,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) @@ -40739,6 +40759,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 @@ -40975,7 +41008,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 x k -> k (type_label_exp true env loc ty_record (process_optional_label x))) opath lid_sexp_list) (fun x -> x) in @@ -40994,8 +41027,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 @@ -41046,7 +41078,8 @@ 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 x k -> + k (type_label_exp true env loc ty_record (process_optional_label x))) opath lid_sexp_list) (fun x -> x) in @@ -44325,7 +44358,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) @@ -69855,7 +69889,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 @@ -269835,7 +269869,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 _ -> @@ -269853,7 +269888,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) @@ -270075,7 +270111,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) *) @@ -270090,7 +270126,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 }) @@ -270114,12 +270151,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 @@ -270136,11 +270174,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 @@ -270177,7 +270216,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) diff --git a/lib/4.06.1/unstable/js_playground_compiler.ml b/lib/4.06.1/unstable/js_playground_compiler.ml index 4d0ca2aece..dbc72f670c 100644 --- a/lib/4.06.1/unstable/js_playground_compiler.ml +++ b/lib/4.06.1/unstable/js_playground_compiler.ml @@ -5092,7 +5092,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; @@ -5598,11 +5597,13 @@ and type_kind = | Type_open and record_representation = - Record_regular (* All fields are boxed / tagged *) - | Record_object (* All fields are floats *) - | 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 = { @@ -5941,11 +5942,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 = { @@ -6132,7 +6135,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 -> @@ -23706,7 +23713,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} @@ -24100,8 +24107,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 } @@ -32166,9 +32173,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 -> @@ -32187,13 +32191,12 @@ and print_out_type_decl kwd ppf td = print_private td.otype_private !out_type ty in - fprintf ppf "@[<2>@[%t%a@]%t%t%t%t@]" + fprintf ppf "@[<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 = @@ -33312,7 +33315,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 -> @@ -33324,8 +33326,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 -> @@ -33342,7 +33343,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 @@ -34165,7 +34165,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 @@ -34331,7 +34331,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 @@ -34356,10 +34356,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 @@ -34509,7 +34522,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 @@ -36176,11 +36189,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 hasOptional attrs = Ext_list.exists attrs (fun ({txt },_) -> txt = "optional") in + let optionalLabels = + Ext_list.filter_map lbls + (fun lbl -> if hasOptional 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 hasOptional 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) @@ -38258,7 +38285,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 @@ -39171,14 +39199,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) @@ -40739,6 +40759,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 @@ -40975,7 +41008,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 x k -> k (type_label_exp true env loc ty_record (process_optional_label x))) opath lid_sexp_list) (fun x -> x) in @@ -40994,8 +41027,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 @@ -41046,7 +41078,8 @@ 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 x k -> + k (type_label_exp true env loc ty_record (process_optional_label x))) opath lid_sexp_list) (fun x -> x) in @@ -44325,7 +44358,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) @@ -69855,7 +69889,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 @@ -290717,7 +290751,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 _ -> @@ -290735,7 +290770,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) @@ -290957,7 +290993,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) *) @@ -290972,7 +291008,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 }) @@ -290996,12 +291033,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 @@ -291018,11 +291056,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 @@ -291059,7 +291098,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) diff --git a/lib/4.06.1/whole_compiler.ml b/lib/4.06.1/whole_compiler.ml index 7abec77d2c..bac573334f 100644 --- a/lib/4.06.1/whole_compiler.ml +++ b/lib/4.06.1/whole_compiler.ml @@ -151152,7 +151152,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; @@ -151658,11 +151657,13 @@ and type_kind = | Type_open and record_representation = - Record_regular (* All fields are boxed / tagged *) - | Record_object (* All fields are floats *) - | 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 = { @@ -152001,11 +152002,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 = { @@ -152192,7 +152195,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 -> @@ -161919,7 +161926,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} @@ -162313,8 +162320,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 } @@ -206697,9 +206704,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 -> @@ -206718,13 +206722,12 @@ and print_out_type_decl kwd ppf td = print_private td.otype_private !out_type ty in - fprintf ppf "@[<2>@[%t%a@]%t%t%t%t@]" + fprintf ppf "@[<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 = @@ -207843,7 +207846,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 -> @@ -207855,8 +207857,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 -> @@ -207873,7 +207874,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 @@ -208696,7 +208696,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 @@ -208862,7 +208862,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 @@ -208887,10 +208887,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 @@ -209040,7 +209053,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 @@ -210707,11 +210720,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 hasOptional attrs = Ext_list.exists attrs (fun ({txt },_) -> txt = "optional") in + let optionalLabels = + Ext_list.filter_map lbls + (fun lbl -> if hasOptional 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 hasOptional 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) @@ -212789,7 +212816,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 @@ -213702,14 +213730,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) @@ -215270,6 +215290,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 @@ -215506,7 +215539,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 x k -> k (type_label_exp true env loc ty_record (process_optional_label x))) opath lid_sexp_list) (fun x -> x) in @@ -215525,8 +215558,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 @@ -215577,7 +215609,8 @@ 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 x k -> + k (type_label_exp true env loc ty_record (process_optional_label x))) opath lid_sexp_list) (fun x -> x) in @@ -218856,7 +218889,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) @@ -238023,7 +238057,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 @@ -267689,7 +267723,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" @@ -272962,7 +272998,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 _ -> @@ -272980,7 +273017,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) @@ -273202,7 +273240,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) *) @@ -273217,7 +273255,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 }) @@ -273241,12 +273280,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 @@ -273263,11 +273303,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 @@ -273304,7 +273345,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)