From ccad030c68b131a86162e954451a6b472b92fb2a Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Thu, 3 Sep 2026 13:34:39 +0200 Subject: [PATCH 01/10] Name the runtime name of a record field once A record field is named by its [@as("...")] attribute when it has one and by its declared name otherwise. That rule was written out nine times inside lambda.ml, once more in typecore_record_rest, and reached record_attributes_check through Lambda.find_name - so the IR module was parsing attribute payloads on behalf of two other layers. Record_runtime holds it now, next to Variant_runtime, which already owns how a variant is represented at run time. The nine sites in lambda.ml ask for the name instead of deriving it, and the other two callers share the same definition. lambda.ml no longer mentions Parsetree or Ast_payload. It still takes Types.label_description, since the tag_info builders are given labels; passing them decoded names instead would move the decoding to translcore, which is a separate question. Generated JavaScript is unchanged. Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/record_attributes_check.ml | 2 +- compiler/ml/lambda.ml | 30 +++++++----------------- compiler/ml/lambda.mli | 2 -- compiler/ml/record_runtime.ml | 30 ++++++++++++++++++++++++ compiler/ml/record_runtime.mli | 27 +++++++++++++++++++++ compiler/ml/typecore_record_rest.ml | 10 ++------ 6 files changed, 69 insertions(+), 32 deletions(-) create mode 100644 compiler/ml/record_runtime.ml create mode 100644 compiler/ml/record_runtime.mli diff --git a/compiler/core/record_attributes_check.ml b/compiler/core/record_attributes_check.ml index 7b30738b42..1c61e3694d 100644 --- a/compiler/core/record_attributes_check.ml +++ b/compiler/core/record_attributes_check.ml @@ -24,7 +24,7 @@ type label = Types.label_description -let find_name = Lambda.find_name +let find_name = Record_runtime.as_name let find_name_with_loc (({txt; loc}, payload) : Parsetree.attribute) : string Asttypes.loc option = diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 68cad6e908..7a3284fb59 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -63,22 +63,17 @@ let mutable_flag_of_tag_info (tag : tag_info) = type label = Types.label_description -let find_name (({txt}, payload) : Parsetree.attribute) = - if txt = "as" then Ast_payload.semantic_string_of_payload payload else None - let blk_record (fields : (label * _ * _) array) mut = let all_labels_info = Ext_array.map fields (fun (lbl, _, _) -> - ( Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name, - lbl.lbl_optional )) + (Record_runtime.label_name lbl, lbl.lbl_optional)) in Blk_record {fields = all_labels_info; mutable_flag = mut} let blk_record_ext fields mutable_flag = let all_labels_info = Array.map - (fun ((lbl : label), _, _) -> - Ext_list.find_def lbl.Types.lbl_attributes find_name lbl.lbl_name) + (fun ((lbl : label), _, _) -> Record_runtime.label_name lbl) fields in Blk_record_ext {fields = all_labels_info; mutable_flag} @@ -87,8 +82,7 @@ let blk_record_inlined fields name num_nonconst ~runtime mutable_flag = let fields = Array.map (fun ((lbl : label), _, _) -> - ( Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name, - lbl.lbl_optional )) + (Record_runtime.label_name lbl, lbl.lbl_optional)) fields in Blk_record_inlined {fields; name; num_nonconst; mutable_flag; runtime} @@ -108,13 +102,10 @@ type field_dbg_info = | Fld_variant | Fld_cons -let fld_record (lbl : label) = - Fld_record - {name = Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name} +let fld_record (lbl : label) = Fld_record {name = Record_runtime.label_name lbl} let fld_record_extension (lbl : label) = - Fld_record_extension - {name = Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name} + Fld_record_extension {name = Record_runtime.label_name lbl} let ref_field_info : field_dbg_info = Fld_record {name = "contents"} @@ -125,19 +116,16 @@ type set_field_dbg_info = let ref_field_set_info : set_field_dbg_info = Fld_record_set "contents" let fld_record_set (lbl : label) = - Fld_record_set (Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name) + Fld_record_set (Record_runtime.label_name lbl) let fld_record_inline (lbl : label) = - Fld_record_inline - {name = Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name} + Fld_record_inline {name = Record_runtime.label_name lbl} let fld_record_inline_set (lbl : label) = - Fld_record_inline_set - (Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name) + Fld_record_inline_set (Record_runtime.label_name lbl) let fld_record_extension_set (lbl : label) = - Fld_record_extension_set - (Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name) + Fld_record_extension_set (Record_runtime.label_name lbl) type immediate_or_pointer = Immediate | Pointer diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index d10c347064..037fb1ce88 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -52,8 +52,6 @@ type tag_info = *) | Blk_record_ext of {fields: string array; mutable_flag: mutable_flag} -val find_name : Parsetree.attribute -> Asttypes.label option - val tag_label_of_tag_info : tag_info -> string val mutable_flag_of_tag_info : tag_info -> mutable_flag val blk_record : diff --git a/compiler/ml/record_runtime.ml b/compiler/ml/record_runtime.ml new file mode 100644 index 0000000000..e398f3e2bd --- /dev/null +++ b/compiler/ml/record_runtime.ml @@ -0,0 +1,30 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* How a record field is named at run time. A field carries the name it was + declared with unless an [@as("...")] attribute renames it, and that choice + is made once here rather than re-derived wherever a field name is needed. *) + +let as_name (({txt}, payload) : Parsetree.attribute) = + if txt = "as" then Ast_payload.semantic_string_of_payload payload else None + +let field_name declared_name attributes = + Ext_list.find_def attributes as_name declared_name + +let label_name (lbl : Types.label_description) = + field_name lbl.lbl_name lbl.lbl_attributes + +let declaration_name (lbl : Types.label_declaration) = + field_name (Ident.name lbl.ld_id) lbl.ld_attributes diff --git a/compiler/ml/record_runtime.mli b/compiler/ml/record_runtime.mli new file mode 100644 index 0000000000..be5a5f6dcd --- /dev/null +++ b/compiler/ml/record_runtime.mli @@ -0,0 +1,27 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* How a record field is named at run time. *) + +val as_name : Parsetree.attribute -> string option +(** The string an [@as("...")] attribute carries, if this is one. *) + +val field_name : string -> Parsetree.attributes -> string +(** The runtime name of a field declared as [declared_name] with [attributes]: + the [@as] payload when there is one, otherwise the declared name. *) + +val label_name : Types.label_description -> string + +val declaration_name : Types.label_declaration -> string diff --git a/compiler/ml/typecore_record_rest.ml b/compiler/ml/typecore_record_rest.ml index aa7ed86148..a68fd32dad 100644 --- a/compiler/ml/typecore_record_rest.ml +++ b/compiler/ml/typecore_record_rest.ml @@ -27,14 +27,8 @@ type source_field = { let raise_error loc env err = raise (Error (loc, env, err)) -let runtime_label_name name attrs = - Ext_list.find_def attrs Lambda.find_name name - -let runtime_label_description_name (lbl : label_description) = - runtime_label_name lbl.lbl_name lbl.lbl_attributes - -let runtime_label_declaration_name (lbl : label_declaration) = - runtime_label_name (Ident.name lbl.ld_id) lbl.ld_attributes +let runtime_label_description_name = Record_runtime.label_name +let runtime_label_declaration_name = Record_runtime.declaration_name let extract_instantiated_concrete_typedecl ~unify_pat_types env loc ty = let _, _, decl = Ctype.extract_concrete_typedecl env ty in From 5b2979224d6aa5f1e47b780b67951633f258a18a Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 4 Sep 2026 15:06:59 +0200 Subject: [PATCH 02/10] Give Lambda a record field's runtime name directly Lambda's nine block and field builders each took a Types.label_description and worked out the field's runtime name themselves. The name is now decided once, when the label description is built, and the builders take it as a plain string: -val fld_record : Types.label_description -> field_dbg_info +val fld_record : string -> field_dbg_info so Lambda no longer reaches into Types or Typedtree to find out what a field is called. Note that typecore's dictionary path copies a label description with a replaced name, so it has to replace the runtime name with it; otherwise every dictionary field reads the name of the original. Signed-off-by: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/ext/config.ml | 4 +- compiler/ml/datarepr.ml | 2 + compiler/ml/lambda.ml | 41 +++--------- compiler/ml/lambda.mli | 24 +++---- compiler/ml/matching.ml | 11 +++- compiler/ml/record_runtime.ml | 3 - compiler/ml/record_runtime.mli | 2 - compiler/ml/translcore.ml | 62 +++++++++++++------ compiler/ml/typecore.ml | 1 + compiler/ml/typecore_record_rest.ml | 4 +- compiler/ml/types.ml | 4 ++ compiler/ml/types.mli | 4 ++ .../ounit_pattern_printer_tests.ml | 1 + 13 files changed, 84 insertions(+), 79 deletions(-) diff --git a/compiler/ext/config.ml b/compiler/ext/config.ml index 25c05907f9..565c6d1385 100644 --- a/compiler/ext/config.ml +++ b/compiler/ext/config.ml @@ -1,4 +1,4 @@ -let cmi_magic_number = "Caml1999I030" +let cmi_magic_number = "Caml1999I031" (* Magic numbers for marshaled values of the *current* parsetree, whose layout changes across compiler versions. *) @@ -13,6 +13,6 @@ and ast0_impl_magic_number = "Caml1999M022" and ast0_intf_magic_number = "Caml1999N022" -and cmt_magic_number = "Caml1999T032" +and cmt_magic_number = "Caml1999T033" let load_path = ref ([] : string list) diff --git a/compiler/ml/datarepr.ml b/compiler/ml/datarepr.ml index f4b63fb30d..ab0195b9b0 100644 --- a/compiler/ml/datarepr.ml +++ b/compiler/ml/datarepr.ml @@ -239,6 +239,7 @@ let none = {desc = Ttuple []; level = -1; id = -1} let dummy_label = { lbl_name = ""; + lbl_runtime_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable; @@ -259,6 +260,7 @@ let label_descrs ty_res lbls repres priv = let lbl = { lbl_name = Ident.name l.ld_id; + lbl_runtime_name = Record_runtime.declaration_name l; lbl_res = ty_res; lbl_arg = l.ld_type; lbl_mut = l.ld_mutable; diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 7a3284fb59..7c961e3ad0 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -61,30 +61,10 @@ let mutable_flag_of_tag_info (tag : tag_info) = | Blk_module_export _ | Blk_extension -> Immutable -type label = Types.label_description - -let blk_record (fields : (label * _ * _) array) mut = - let all_labels_info = - Ext_array.map fields (fun (lbl, _, _) -> - (Record_runtime.label_name lbl, lbl.lbl_optional)) - in - Blk_record {fields = all_labels_info; mutable_flag = mut} - -let blk_record_ext fields mutable_flag = - let all_labels_info = - Array.map - (fun ((lbl : label), _, _) -> Record_runtime.label_name lbl) - fields - in - Blk_record_ext {fields = all_labels_info; mutable_flag} +let blk_record fields mutable_flag = Blk_record {fields; mutable_flag} +let blk_record_ext fields mutable_flag = Blk_record_ext {fields; mutable_flag} let blk_record_inlined fields name num_nonconst ~runtime mutable_flag = - let fields = - Array.map - (fun ((lbl : label), _, _) -> - (Record_runtime.label_name lbl, lbl.lbl_optional)) - fields - in Blk_record_inlined {fields; name; num_nonconst; mutable_flag; runtime} let ref_tag_info : tag_info = @@ -102,10 +82,9 @@ type field_dbg_info = | Fld_variant | Fld_cons -let fld_record (lbl : label) = Fld_record {name = Record_runtime.label_name lbl} +let fld_record name = Fld_record {name} -let fld_record_extension (lbl : label) = - Fld_record_extension {name = Record_runtime.label_name lbl} +let fld_record_extension name = Fld_record_extension {name} let ref_field_info : field_dbg_info = Fld_record {name = "contents"} @@ -115,17 +94,13 @@ type set_field_dbg_info = | Fld_record_extension_set of string let ref_field_set_info : set_field_dbg_info = Fld_record_set "contents" -let fld_record_set (lbl : label) = - Fld_record_set (Record_runtime.label_name lbl) +let fld_record_set name = Fld_record_set name -let fld_record_inline (lbl : label) = - Fld_record_inline {name = Record_runtime.label_name lbl} +let fld_record_inline name = Fld_record_inline {name} -let fld_record_inline_set (lbl : label) = - Fld_record_inline_set (Record_runtime.label_name lbl) +let fld_record_inline_set name = Fld_record_inline_set name -let fld_record_extension_set (lbl : label) = - Fld_record_extension_set (Record_runtime.label_name lbl) +let fld_record_extension_set name = Fld_record_extension_set name type immediate_or_pointer = Immediate | Pointer diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 037fb1ce88..4a3d81b577 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -54,18 +54,12 @@ type tag_info = val tag_label_of_tag_info : tag_info -> string val mutable_flag_of_tag_info : tag_info -> mutable_flag -val blk_record : - (Types.label_description * Typedtree.record_label_definition * bool) array -> - mutable_flag -> - tag_info +val blk_record : (string * bool) array -> mutable_flag -> tag_info -val blk_record_ext : - (Types.label_description * Typedtree.record_label_definition * bool) array -> - mutable_flag -> - tag_info +val blk_record_ext : string array -> mutable_flag -> tag_info val blk_record_inlined : - (Types.label_description * Typedtree.record_label_definition * bool) array -> + (string * bool) array -> string -> int -> runtime:Variant_runtime.block_runtime -> @@ -86,11 +80,11 @@ type field_dbg_info = | Fld_variant | Fld_cons -val fld_record : Types.label_description -> field_dbg_info +val fld_record : string -> field_dbg_info -val fld_record_inline : Types.label_description -> field_dbg_info +val fld_record_inline : string -> field_dbg_info -val fld_record_extension : Types.label_description -> field_dbg_info +val fld_record_extension : string -> field_dbg_info val ref_field_info : field_dbg_info @@ -101,11 +95,11 @@ type set_field_dbg_info = val ref_field_set_info : set_field_dbg_info -val fld_record_set : Types.label_description -> set_field_dbg_info +val fld_record_set : string -> set_field_dbg_info -val fld_record_inline_set : Types.label_description -> set_field_dbg_info +val fld_record_inline_set : string -> set_field_dbg_info -val fld_record_extension_set : Types.label_description -> set_field_dbg_info +val fld_record_extension_set : string -> set_field_dbg_info type immediate_or_pointer = Immediate | Pointer diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index 15542f4a75..e1bdf871d1 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -1489,17 +1489,22 @@ let make_record_matching loc all_labels def = function | Record_float_unused -> assert false | Record_regular -> prim - ~primitive:(Pfield (lbl.lbl_pos, Lambda.fld_record lbl)) + ~primitive: + (Pfield (lbl.lbl_pos, Lambda.fld_record lbl.lbl_runtime_name)) ~args:[arg] loc | Record_inlined _ -> prim - ~primitive:(Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl)) + ~primitive: + (Pfield + (lbl.lbl_pos, Lambda.fld_record_inline lbl.lbl_runtime_name)) ~args:[arg] loc | Record_unboxed _ -> arg | Record_extension -> prim ~primitive: - (Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl)) + (Pfield + ( lbl.lbl_pos + 1, + Lambda.fld_record_extension lbl.lbl_runtime_name )) ~args:[arg] loc in let str = diff --git a/compiler/ml/record_runtime.ml b/compiler/ml/record_runtime.ml index e398f3e2bd..af443ca32d 100644 --- a/compiler/ml/record_runtime.ml +++ b/compiler/ml/record_runtime.ml @@ -23,8 +23,5 @@ let as_name (({txt}, payload) : Parsetree.attribute) = let field_name declared_name attributes = Ext_list.find_def attributes as_name declared_name -let label_name (lbl : Types.label_description) = - field_name lbl.lbl_name lbl.lbl_attributes - let declaration_name (lbl : Types.label_declaration) = field_name (Ident.name lbl.ld_id) lbl.ld_attributes diff --git a/compiler/ml/record_runtime.mli b/compiler/ml/record_runtime.mli index be5a5f6dcd..73468e136e 100644 --- a/compiler/ml/record_runtime.mli +++ b/compiler/ml/record_runtime.mli @@ -22,6 +22,4 @@ val field_name : string -> Parsetree.attributes -> string (** The runtime name of a field declared as [declared_name] with [attributes]: the [@as] payload when there is one, otherwise the declared name. *) -val label_name : Types.label_description -> string - val declaration_name : Types.label_declaration -> string diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index eeded0f64b..0c0f5365bc 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -1221,27 +1221,34 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.t = | Record_float_unused -> assert false | Record_regular -> prim - ~primitive:(Pfield (lbl.lbl_pos, Lambda.fld_record lbl)) + ~primitive: + (Pfield (lbl.lbl_pos, Lambda.fld_record lbl.lbl_runtime_name)) ~args:[targ] e.exp_loc | Record_inlined _ -> prim - ~primitive:(Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl)) + ~primitive: + (Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl.lbl_runtime_name)) ~args:[targ] e.exp_loc | Record_unboxed _ -> targ | Record_extension -> prim - ~primitive:(Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl)) + ~primitive: + (Pfield + (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl.lbl_runtime_name)) ~args:[targ] e.exp_loc) | Texp_setfield (arg, _, lbl, newval) -> let access = match lbl.lbl_repres with | Record_float_unused -> assert false - | Record_regular -> Psetfield (lbl.lbl_pos, Lambda.fld_record_set lbl) + | Record_regular -> + Psetfield (lbl.lbl_pos, Lambda.fld_record_set lbl.lbl_runtime_name) | Record_inlined _ -> - Psetfield (lbl.lbl_pos, Lambda.fld_record_inline_set lbl) + Psetfield + (lbl.lbl_pos, Lambda.fld_record_inline_set lbl.lbl_runtime_name) | Record_unboxed _ -> assert false | Record_extension -> - Psetfield (lbl.lbl_pos + 1, Lambda.fld_record_extension_set lbl) + Psetfield + (lbl.lbl_pos + 1, Lambda.fld_record_extension_set lbl.lbl_runtime_name) in prim ~primitive:access ~args:[transl_exp arg; transl_exp newval] e.exp_loc | Texp_array expr_list -> @@ -1430,6 +1437,16 @@ and transl_let ~js_hoist rec_flag pat_expr_list body = Lambda_scc.bind_rec (Ext_list.map pat_expr_list transl_case) body and transl_record loc env fields repres opt_init_expr = + (* The runtime shape of the record: each field's runtime name, and whether + it is optional. *) + let field_shape () = + Ext_array.map fields (fun ((lbl : Types.label_description), _, _) -> + (lbl.lbl_runtime_name, lbl.lbl_optional)) + in + let field_names () = + Ext_array.map fields (fun ((lbl : Types.label_description), _, _) -> + lbl.lbl_runtime_name) + in match (opt_init_expr, repres, fields) with | _ -> ( let size = Array.length fields in @@ -1460,11 +1477,14 @@ and transl_record loc env fields repres opt_init_expr = let access = match repres with | Record_float_unused -> assert false - | Record_regular -> Pfield (i, Lambda.fld_record lbl) - | Record_inlined _ -> Pfield (i, Lambda.fld_record_inline lbl) + | Record_regular -> + Pfield (i, Lambda.fld_record lbl.lbl_runtime_name) + | Record_inlined _ -> + Pfield (i, Lambda.fld_record_inline lbl.lbl_runtime_name) | Record_unboxed _ -> assert false | Record_extension -> - Pfield (i + 1, Lambda.fld_record_extension lbl) + Pfield + (i + 1, Lambda.fld_record_extension lbl.lbl_runtime_name) in prim ~primitive:access ~args:[var init_id] loc | Overridden (_lid, expr) -> transl_exp expr) @@ -1483,7 +1503,7 @@ and transl_record loc env fields repres opt_init_expr = match repres with | Record_float_unused -> assert false | Record_regular -> - const (Const_block (Lambda.blk_record fields mut, cl)) + const (Const_block (Lambda.blk_record (field_shape ()) mut, cl)) | Record_inlined {name; representation} -> let runtime = match Variant_runtime.representation representation with @@ -1496,8 +1516,8 @@ and transl_record loc env fields repres opt_init_expr = in const (Const_block - ( Lambda.blk_record_inlined fields name num_nonconsts ~runtime - mut, + ( Lambda.blk_record_inlined (field_shape ()) name num_nonconsts + ~runtime mut, cl )) | Record_unboxed _ -> const @@ -1509,7 +1529,7 @@ and transl_record loc env fields repres opt_init_expr = match repres with | Record_regular -> prim - ~primitive:(Pmakeblock (Lambda.blk_record fields mut)) + ~primitive:(Pmakeblock (Lambda.blk_record (field_shape ()) mut)) ~args:ll loc | Record_float_unused -> assert false | Record_inlined {name; representation} -> @@ -1525,8 +1545,8 @@ and transl_record loc env fields repres opt_init_expr = prim ~primitive: (Pmakeblock - (Lambda.blk_record_inlined fields name num_nonconsts ~runtime - mut)) + (Lambda.blk_record_inlined (field_shape ()) name + num_nonconsts ~runtime mut)) ~args:ll loc | Record_unboxed _ -> ( match ll with @@ -1541,7 +1561,8 @@ and transl_record loc env fields repres opt_init_expr = in let slot = Transl_path.transl_extension_path env path in prim - ~primitive:(Pmakeblock (Lambda.blk_record_ext fields mut)) + ~primitive: + (Pmakeblock (Lambda.blk_record_ext (field_names ()) mut)) ~args:(slot :: ll) loc) in match opt_init_expr with @@ -1559,12 +1580,15 @@ and transl_record loc env fields repres opt_init_expr = match repres with | Record_float_unused -> assert false | Record_regular -> - Psetfield (lbl.lbl_pos, Lambda.fld_record_set lbl) + Psetfield (lbl.lbl_pos, Lambda.fld_record_set lbl.lbl_runtime_name) | Record_inlined _ -> - Psetfield (lbl.lbl_pos, Lambda.fld_record_inline_set lbl) + Psetfield + (lbl.lbl_pos, Lambda.fld_record_inline_set lbl.lbl_runtime_name) | Record_unboxed _ -> assert false | Record_extension -> - Psetfield (lbl.lbl_pos + 1, Lambda.fld_record_extension_set lbl) + Psetfield + ( lbl.lbl_pos + 1, + Lambda.fld_record_extension_set lbl.lbl_runtime_name ) in seq (prim ~primitive:upd ~args:[var copy_id; transl_exp expr] loc) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 00b6b60e72..bf11f7d7b4 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -987,6 +987,7 @@ module Label = Name_choice (struct { lbl with lbl_name = name; + lbl_runtime_name = name; lbl_pos = Array.length lbl.lbl_all; lbl_repres = Record_regular; } diff --git a/compiler/ml/typecore_record_rest.ml b/compiler/ml/typecore_record_rest.ml index a68fd32dad..820e48ccd5 100644 --- a/compiler/ml/typecore_record_rest.ml +++ b/compiler/ml/typecore_record_rest.ml @@ -27,7 +27,6 @@ type source_field = { let raise_error loc env err = raise (Error (loc, env, err)) -let runtime_label_description_name = Record_runtime.label_name let runtime_label_declaration_name = Record_runtime.declaration_name let extract_instantiated_concrete_typedecl ~unify_pat_types env loc ty = @@ -161,7 +160,8 @@ let type_record_pat_rest ~env ~pattern_force ~loc ~record_ty ~lbl_pat_list ~rest in let explicit_runtime_labels = List.map - (fun (_, label, _, _) -> runtime_label_description_name label) + (fun (_, (label : Types.label_description), _, _) -> + label.lbl_runtime_name) lbl_pat_list in let explicit_optional_fields = diff --git a/compiler/ml/types.ml b/compiler/ml/types.ml index da22631825..f30e85d68b 100644 --- a/compiler/ml/types.ml +++ b/compiler/ml/types.ml @@ -294,6 +294,10 @@ let may_equal_constr c1 c2 = type label_description = { lbl_name: string; (* Short name *) + lbl_runtime_name: string; + (* The name the field has at run time: its [@as] payload when it has + one, otherwise [lbl_name]. Decided once when the declaration is + typed, so no consumer re-reads the attribute. *) lbl_res: type_expr; (* Type of the result *) lbl_arg: type_expr; (* Type of the argument *) lbl_mut: mutable_flag; (* Is this a mutable field? *) diff --git a/compiler/ml/types.mli b/compiler/ml/types.mli index a7f62419f2..968d0ba812 100644 --- a/compiler/ml/types.mli +++ b/compiler/ml/types.mli @@ -380,6 +380,10 @@ val may_equal_constr : type label_description = { lbl_name: string; (* Short name *) + lbl_runtime_name: string; + (* The name the field has at run time: its [@as] payload when it has + one, otherwise [lbl_name]. Decided once when the declaration is + typed, so no consumer re-reads the attribute. *) lbl_res: type_expr; (* Type of the result *) lbl_arg: type_expr; (* Type of the argument *) lbl_mut: mutable_flag; (* Is this a mutable field? *) diff --git a/tests/ounit_tests/ounit_pattern_printer_tests.ml b/tests/ounit_tests/ounit_pattern_printer_tests.ml index daa1ef026f..9ee5e21ad9 100644 --- a/tests/ounit_tests/ounit_pattern_printer_tests.ml +++ b/tests/ounit_tests/ounit_pattern_printer_tests.ml @@ -42,6 +42,7 @@ let count_label = let label = { Types.lbl_name = "count"; + lbl_runtime_name = "count"; lbl_res = record_type; lbl_arg = Predef.type_int; lbl_mut = Asttypes.Immutable; From febcccc99607e13d2dd6b3c6b6f3578e39c0fd03 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 4 Sep 2026 15:07:09 +0200 Subject: [PATCH 03/10] Make @as on a record field part of the AST @as("x") renames a record field at run time. It was an attribute that seven separate places re-read and re-interpreted: record construction and access, record spread, record coercion, signature inclusion, duplicate-field detection, the @tag conflict check, @deriving(abstract) and gentype. The declaration now records the runtime name, and they all read the same field. Extraction happens in Ast_helper.Type.field, so the parser, every ppx and the frozen-AST bridge inherit it: ast_mapper_from0 needs no change at all, and ast_mapper_to0 puts the attribute back the way it already does for pld_optional. This removes the two hooks installed into Builtin_attributes to reach an attribute reader from compiler/core, and the module that filled them. @as keeps its surface syntax. The parsetree holds the literal with its source spelling and its own location, so printers put it back exactly where it was written; the typed tree holds only the decoded name, which is what Asttypes.constant already does for every other string literal. A payload that does not denote a name is left alone, and a second @as is left for the type checker rather than rejected at parse time, so an invalid file can still be formatted. Signed-off-by: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- CHANGELOG.md | 2 + analysis/src/completion_front_end.ml | 95 +++++++++++-------- compiler/core/bs_conditional_initial.ml | 5 - compiler/core/record_attributes_check.ml | 63 ------------ compiler/ext/config.ml | 4 +- compiler/frontend/ast_derive_abstract.ml | 7 +- .../gentype/translate_type_declarations.ml | 15 ++- compiler/ml/ast_helper.ml | 59 +++++++++++- compiler/ml/ast_helper.mli | 8 ++ compiler/ml/ast_mapper.ml | 6 +- compiler/ml/ast_mapper_to0.ml | 4 +- compiler/ml/ast_payload.ml | 19 ++++ compiler/ml/ast_payload.mli | 5 + compiler/ml/ast_untagged_variants.ml | 7 +- compiler/ml/builtin_attributes.ml | 4 - compiler/ml/builtin_attributes.mli | 9 -- compiler/ml/includecore.ml | 12 +-- compiler/ml/parsetree.ml | 6 ++ compiler/ml/pprintast.ml | 3 +- compiler/ml/predef.ml | 1 + compiler/ml/printast.ml | 5 +- compiler/ml/record_coercion.ml | 23 ++--- compiler/ml/record_runtime.ml | 41 ++++++-- compiler/ml/record_runtime.mli | 13 +-- compiler/ml/record_type_spread.ml | 1 + compiler/ml/subst.ml | 1 + compiler/ml/typedecl.ml | 31 ++++-- compiler/ml/typedtree.ml | 1 + compiler/ml/typedtree.mli | 1 + compiler/ml/types.ml | 9 ++ compiler/ml/types.mli | 9 ++ compiler/ml/variant_type_spread.ml | 1 + compiler/syntax/src/res_core.ml | 23 ++--- compiler/syntax/src/res_printer.ml | 6 +- .../tests/src/CompletionAttributes.res | 2 + .../src/expected/CompletionAttributes.res.txt | 20 ++++ tests/ounit_tests/ounit_ast_mapper0_tests.ml | 90 ++++++++++++++++++ .../data/ast-mapping/RecordFieldNames.res | 20 ++++ .../expected/RecordFieldNames.res.txt | 20 ++++ .../src/record_field_as_spelling_test.mjs | 21 ++++ .../src/record_field_as_spelling_test.res | 16 ++++ 41 files changed, 485 insertions(+), 203 deletions(-) delete mode 100644 compiler/core/record_attributes_check.ml create mode 100644 tests/syntax_tests/data/ast-mapping/RecordFieldNames.res create mode 100644 tests/syntax_tests/data/ast-mapping/expected/RecordFieldNames.res.txt create mode 100644 tests/tests/src/record_field_as_spelling_test.mjs create mode 100644 tests/tests/src/record_field_as_spelling_test.res diff --git a/CHANGELOG.md b/CHANGELOG.md index a5851dee35..1ec967e4db 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -66,12 +66,14 @@ - Print external declarations in signatures and type errors with their processed attributes instead of the `"#rescript-external"` placeholder, and print inline constants using `@inline` syntax. https://github.com/rescript-lang/rescript/pull/8581 - Improve diagnostics for dynamic imports of local values and attempts to use `import` as a first-class value. https://github.com/rescript-lang/rescript/pull/8582 - Allow inferred labeled functions to be called with labels in any order by removing legacy curried-arrow commutation locks. https://github.com/rescript-lang/rescript/pull/8547 +- Format a record field's `@as` rename written as a backquoted string with ordinary quotes, since it names the same field either way. https://github.com/rescript-lang/rescript/pull/NNNN #### :house: Internal - Normalize Lambda terms where they are built: a match guard stays structured data until its fallthrough is known, and `apply` and `mk_builtin` go through the folding constructors. https://github.com/rescript-lang/rescript/pull/8615 - Replace non-escaping local mutable blocks with scalar bindings when all uses are direct field accesses, generalizing reference unboxing to multi-field records and references captured by JavaScript closures. https://github.com/rescript-lang/rescript/pull/8617 - Split `lambda.ml` into the IR and its traversals, static exits and path translation, so the module defining `Lambda.t` no longer reaches into `Env` or `Path`. https://github.com/rescript-lang/rescript/pull/8618 +- Record a record field's `@as` rename on the declaration instead of re-reading the attribute, so every place that needs the runtime name reads one field. https://github.com/rescript-lang/rescript/pull/8619 - Merge the duplicate Lam intermediate representation into Lambda, removing the conversion layer and obsolete supporting infrastructure. Lambda is now a single private, normalized representation, with generated JavaScript remaining semantically unchanged. https://github.com/rescript-lang/rescript/pull/8608 - Add genType and source map controls and output to the developer playground. https://github.com/rescript-lang/rescript/pull/8448 - Rework the object-type representation end to end: object rows are plain field chains carrying a per-field mutability state (no phantom setter members), object literals are typed directly and property access and assignment are first-class AST and Lambda nodes shared between the Lambda and JS pipelines, and dead class-system remnants (the field-presence lattice, the class-abbreviation memo on object types, method-send typing) are removed. https://github.com/rescript-lang/rescript/pull/8597 diff --git a/analysis/src/completion_front_end.ml b/analysis/src/completion_front_end.ml index a3ed213e9f..3356797ca8 100644 --- a/analysis/src/completion_front_end.ml +++ b/analysis/src/completion_front_end.ml @@ -892,51 +892,57 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file if not !processed then Ast_iterator.default_iterator.signature_item iterator item in + (* A decorator whose name spans the cursor completes decorator names. The + label is taken from the source text under the location, since the + parser's location can run past the name: [@foo. let x] gives [@foo.let]. + A field's [@as] is a field of the declaration rather than an attribute, + so [label_declaration] below reports its location here too. *) + let decorator_at ~id_txt (id_loc : Location.t) = + let pos_start, pos_end = Loc.range id_loc in + match + ( Pos.position_to_offset text pos_start, + Pos.position_to_offset text pos_end ) + with + | Some offset_start, Some offset_end + when offset_start >= 0 && offset_end >= offset_start -> + let label = + let raw_label = + String.sub text offset_start (offset_end - offset_start) + in + let ( ++ ) x y = + match (x, y) with + | Some i1, Some i2 -> Some (min i1 i2) + | Some _, None -> x + | None, _ -> y + in + let label = + match + String.index_opt raw_label ' ' + ++ String.index_opt raw_label '\t' + ++ String.index_opt raw_label '\r' + ++ String.index_opt raw_label '\n' + with + | None -> raw_label + | Some i -> String.sub raw_label 0 i + in + if label <> "" && label.[0] = '@' then + String.sub label 1 (String.length label - 1) + else label + in + found := true; + if debug then + Printf.printf "Attribute id:%s:%s label:%s\n" id_txt + (Loc.to_string id_loc) label; + set_result (Completable.Cdecorator label) + | _ -> () + in let attribute (iterator : Ast_iterator.iterator) ((id, payload) : Parsetree.attribute) = (if String.length id.txt >= 4 && String.sub id.txt 0 4 = "res." then (* skip: internal parser attribute *) () else if id.loc.loc_ghost then () else if id.loc |> Loc.has_pos ~pos:pos_before_cursor then - let pos_start, pos_end = Loc.range id.loc in - match - ( Pos.position_to_offset text pos_start, - Pos.position_to_offset text pos_end ) - with - | Some offset_start, Some offset_end - when offset_start >= 0 && offset_end >= offset_start -> - (* Can't trust the parser's location - E.g. @foo. let x... gives as label @foo.let *) - let label = - let raw_label = - String.sub text offset_start (offset_end - offset_start) - in - let ( ++ ) x y = - match (x, y) with - | Some i1, Some i2 -> Some (min i1 i2) - | Some _, None -> x - | None, _ -> y - in - let label = - match - String.index_opt raw_label ' ' - ++ String.index_opt raw_label '\t' - ++ String.index_opt raw_label '\r' - ++ String.index_opt raw_label '\n' - with - | None -> raw_label - | Some i -> String.sub raw_label 0 i - in - if label <> "" && label.[0] = '@' then - String.sub label 1 (String.length label - 1) - else label - in - found := true; - if debug then - Printf.printf "Attribute id:%s:%s label:%s\n" id.txt - (Loc.to_string id.loc) label; - set_result (Completable.Cdecorator label) - | _ -> () + decorator_at ~id_txt:id.txt id.loc else if id.txt = "module" then match payload with | PStr @@ -1844,11 +1850,22 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file if Loc.end_ loc <= pos_cursor then last_scope_before_cursor := !scope in + let label_declaration (iterator : Ast_iterator.iterator) + (ld : Parsetree.label_declaration) = + (match ld.pld_runtime_name with + | Some {loc} + when (not loc.loc_ghost) && Loc.has_pos loc ~pos:pos_before_cursor -> + decorator_at ~id_txt:"as" loc + | _ -> ()); + Ast_iterator.default_iterator.label_declaration iterator ld + in + let iterator = { Ast_iterator.default_iterator with attribute; expr; + label_declaration; location; module_expr; module_type; diff --git a/compiler/core/bs_conditional_initial.ml b/compiler/core/bs_conditional_initial.ml index ba6bf27c51..cf40765964 100644 --- a/compiler/core/bs_conditional_initial.ml +++ b/compiler/core/bs_conditional_initial.ml @@ -40,11 +40,6 @@ let setup_env () = Clflags.binary_annotations := true; (* Turn on [-no-alias-deps] by default -- double check *) Oprint.out_ident := Outcome_printer_ns.out_ident; - Builtin_attributes.check_bs_attributes_inclusion := - Record_attributes_check.check_bs_attributes_inclusion; - Builtin_attributes.check_duplicated_labels := - Record_attributes_check.check_duplicated_labels; - Printtyp.print_res_poly_identifier := Res_printer.polyvar_ident_to_string (*; Switch.cut := 100*) (* tweakable but not very useful *) diff --git a/compiler/core/record_attributes_check.ml b/compiler/core/record_attributes_check.ml deleted file mode 100644 index 1c61e3694d..0000000000 --- a/compiler/core/record_attributes_check.ml +++ /dev/null @@ -1,63 +0,0 @@ -(* Copyright (C) 2019- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type label = Types.label_description - -let find_name = Record_runtime.as_name - -let find_name_with_loc (({txt; loc}, payload) : Parsetree.attribute) : - string Asttypes.loc option = - if txt = "as" then - Option.map - (fun txt -> {Asttypes.txt; loc}) - (Ast_payload.semantic_string_of_payload payload) - else None - -let check_bs_attributes_inclusion (attrs1 : Parsetree.attributes) - (attrs2 : Parsetree.attributes) lbl_name = - let a = Ext_list.find_def attrs1 find_name lbl_name in - let b = Ext_list.find_def attrs2 find_name lbl_name in - if a = b then None else Some (a, b) - -let rec check_duplicated_labels_aux (lbls : Parsetree.label_declaration list) - (coll : Set_string.t) = - match lbls with - | [] -> None - | {pld_name = {txt} as pld_name; pld_attributes} :: rest -> ( - if Set_string.mem coll txt && txt <> "..." then Some pld_name - else - let coll_with_lbl = Set_string.add coll txt in - match Ext_list.find_opt pld_attributes find_name_with_loc with - | None -> check_duplicated_labels_aux rest coll_with_lbl - | Some ({txt = s} as l) -> - if - Set_string.mem coll s - (*use coll to make check a bit looser - allow cases like [ x : int [@as "x"]] - *) - then Some l - else check_duplicated_labels_aux rest (Set_string.add coll_with_lbl s)) - -let check_duplicated_labels lbls = - check_duplicated_labels_aux lbls Set_string.empty diff --git a/compiler/ext/config.ml b/compiler/ext/config.ml index 565c6d1385..1a187acfa8 100644 --- a/compiler/ext/config.ml +++ b/compiler/ext/config.ml @@ -2,9 +2,9 @@ let cmi_magic_number = "Caml1999I031" (* Magic numbers for marshaled values of the *current* parsetree, whose layout changes across compiler versions. *) -and ast_impl_magic_number = "ResImpl01304" +and ast_impl_magic_number = "ResImpl01305" -and ast_intf_magic_number = "ResIntf01304" +and ast_intf_magic_number = "ResIntf01305" (* Magic numbers of the frozen Parsetree0 (OCaml 4.06) layout used on the external-PPX wire. They must never be written in front of a diff --git a/compiler/frontend/ast_derive_abstract.ml b/compiler/frontend/ast_derive_abstract.ml index 70a8f0c826..d0beb5c829 100644 --- a/compiler/frontend/ast_derive_abstract.ml +++ b/compiler/frontend/ast_derive_abstract.ml @@ -92,6 +92,7 @@ let handle_tdcl light (tdcl : Parsetree.type_declaration) : [] ) (fun ({ pld_name = {txt = label_name; loc = label_loc} as pld_name; + pld_runtime_name; pld_type; pld_mutable; pld_attributes; @@ -101,9 +102,11 @@ let handle_tdcl light (tdcl : Parsetree.type_declaration) : (acc, maker, labels) -> let prim_as_name, new_label = - match Ast_attributes.iter_process_bs_string_as pld_attributes with + match pld_runtime_name with | None -> (label_name, pld_name) - | Some new_name -> (new_name, {pld_name with txt = new_name}) + | Some {txt} -> + let new_name = String_literal.string_semantic txt in + (new_name, {pld_name with txt = new_name}) in let prim = Parsetree.Prim_name prim_as_name in let is_optional = Ast_attributes.has_bs_optional pld_attributes in diff --git a/compiler/gentype/translate_type_declarations.ml b/compiler/gentype/translate_type_declarations.ml index d5d89ffdec..ccd0869cc5 100644 --- a/compiler/gentype/translate_type_declarations.ml +++ b/compiler/gentype/translate_type_declarations.ml @@ -67,6 +67,14 @@ let rename_record_field ~attributes ~name = | Some s -> Emit_text.escape_string_contents s | None -> name |> Ext_ident.unwrap_uppercase_exotic +(* A declared field carries its runtime name; only the renaming that reaches + gentype through an expression's attributes still has to be read off one. *) +let declared_field_name (ld : Types.label_declaration) = + ld.ld_attributes |> Annotation.check_unsupported_gentype_as_renaming; + match ld.ld_runtime_name with + | Some s -> Emit_text.escape_string_contents s + | None -> Ident.name ld.ld_id |> Ext_ident.unwrap_uppercase_exotic + let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver ~type_attributes ~type_env ~type_name ~type_vars declaration_kind : Code_item.type_declaration list = @@ -106,11 +114,8 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver label_declarations |> 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) - in + ({Types.ld_mutable; ld_optional; ld_type; ld_attributes} as ld) -> + let name = declared_field_name ld in let mutability = match ld_mutable = Mutable with | true -> Mutable diff --git a/compiler/ml/ast_helper.ml b/compiler/ml/ast_helper.ml index 658095545a..db191ff1ab 100644 --- a/compiler/ml/ast_helper.ml +++ b/compiler/ml/ast_helper.ml @@ -400,16 +400,73 @@ module Type = struct pcd_attributes = attrs; } + (* [@as("x")] on a record field renames it at run time. It is taken out of + the attributes here, so every producer - the parser, a ppx, the frozen + AST bridge - agrees on what the field is called without re-reading the + payload. *) let field ?(loc = !default_loc) ?(attrs = []) ?(mut = Immutable) - ?(optional = false) name typ = + ?(optional = false) ?runtime_name name typ = + let runtime_name, attrs = + match runtime_name with + | Some txt -> + ( Some + { + txt = String_literal.string_from_semantic txt; + loc = name.Asttypes.loc; + }, + attrs ) + | None -> ( + (* Take out the first [@as] that denotes a name. One whose payload is + not a name is left alone: it does not rename the field, and dropping + it here would make the printer delete it from the source. *) + let rec take seen (attrs : Parsetree.attributes) = + match attrs with + | [] -> (None, []) + | ((({txt = "as"; loc}, payload) : Parsetree.attribute) as attr) + :: rest -> ( + match Ast_payload.string_literal_of_payload payload with + | Some txt -> + (* A second [@as] is left in the attributes for the type checker + to reject, so that an invalid file can still be printed. *) + (Some {Asttypes.txt; loc}, List.rev_append seen rest) + | None -> take (attr :: seen) rest) + | attr :: rest -> take (attr :: seen) rest + in + match take [] attrs with + | None, _ -> (None, attrs) + | found -> found) + in { pld_name = name; + pld_runtime_name = runtime_name; pld_mutable = mut; pld_optional = optional; pld_type = typ; pld_loc = loc; pld_attributes = attrs; } + + (* The attributes as they were written, with the runtime name put back. + Inverse of the extraction in [field], for printers. *) + let field_attributes (ld : Parsetree.label_declaration) = + match ld.pld_runtime_name with + | None -> ld.pld_attributes + | Some {txt; loc} -> + let payload = + Parsetree.PStr [Str.eval ~loc (Exp.constant ~loc (Pconst_string txt))] + in + (* Back where it was written: attributes print in source order, so a + field declared [@optional @as("x")] must not come out reordered. + Ppx output has no source position, so all of it ties on + [Location.none]; the rename then goes last among the tied, which is + the order a ppx writing [@dead @as("x")] gave. Where it sat exactly + is not recoverable without storing an index, which is not worth a + field in the AST. *) + let written_earlier (({loc = other}, _) : Parsetree.attribute) = + other.loc_start.pos_cnum <= loc.loc_start.pos_cnum + in + let earlier, later = List.partition written_earlier ld.pld_attributes in + earlier @ ((Location.mkloc "as" loc, payload) :: later) end (** Type extensions *) diff --git a/compiler/ml/ast_helper.mli b/compiler/ml/ast_helper.mli index 2899c91416..5b7ccc186c 100644 --- a/compiler/ml/ast_helper.mli +++ b/compiler/ml/ast_helper.mli @@ -297,14 +297,22 @@ module Type : sig ?res:core_type -> str -> constructor_declaration + val field : ?loc:loc -> ?attrs:attrs -> ?mut:mutable_flag -> ?optional:bool -> + ?runtime_name:string -> str -> core_type -> label_declaration + (** [@as("x")] in [attrs] is taken out and becomes the runtime name, unless + one is given explicitly. *) + + val field_attributes : label_declaration -> attrs + (** The attributes as written, with the [@as] taken out by [field] put back. + For printers, which must reproduce the source. *) end (** Type extensions *) diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index 99e54d2f4c..2e888c0ac6 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -535,12 +535,14 @@ let default_mapper = ~attrs:(this.attributes this pcd_attributes)); label_declaration = (fun this - {pld_name; pld_type; pld_loc; pld_mutable; pld_optional; pld_attributes} + ({pld_name; pld_type; pld_loc; pld_mutable; pld_optional} as ld) -> + (* The runtime name goes back into the attributes so that a mapper sees + [@as] where it has always been, and [field] takes it out again. *) Type.field (map_loc this pld_name) (this.typ this pld_type) ~mut:pld_mutable ~optional:pld_optional ~loc:(this.location this pld_loc) - ~attrs:(this.attributes this pld_attributes)); + ~attrs:(this.attributes this (Type.field_attributes ld))); cases = (fun this l -> List.map (this.case this) l); case = (fun this {pc_bar; pc_lhs; pc_guard; pc_rhs} -> diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index 030aa7fe59..1cbc1d2bd4 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -932,14 +932,14 @@ let default_mapper = ~attrs:(this.attributes this pcd_attributes)); label_declaration = (fun this - {pld_name; pld_type; pld_loc; pld_mutable; pld_optional; pld_attributes} + ({pld_name; pld_type; pld_loc; pld_mutable; pld_optional} as ld) -> Type.field (map_loc this pld_name) (this.typ this pld_type) ~mut:pld_mutable ~loc:(this.location this pld_loc) ~attrs: (Parsetree0.add_optional_attr ~optional:pld_optional - (this.attributes this pld_attributes))); + (this.attributes this (Ast_helper.Type.field_attributes ld)))); cases = (fun this l -> List.map (this.case this) l); case = (fun this {pc_lhs; pc_guard; pc_rhs} -> diff --git a/compiler/ml/ast_payload.ml b/compiler/ml/ast_payload.ml index 72f81567fb..9f1a16656e 100644 --- a/compiler/ml/ast_payload.ml +++ b/compiler/ml/ast_payload.ml @@ -57,6 +57,25 @@ let semantic_string_of_expression (expression : Parsetree.expression) = Location.raise_errorf ~loc:pexp_loc "Invalid string escape sequence") | _ -> None +let string_literal_of_expression (expression : Parsetree.expression) = + match expression with + | {pexp_desc = Pexp_constant (Pconst_string payload); _} -> Some payload + | { + pexp_desc = Pexp_template {source_segments = [source]; values = []}; + pexp_loc; + } -> ( + match String_literal.decode_js_template_escapes source.txt with + | Some semantic -> Some (String_literal.string_from_semantic semantic) + | None -> + Location.raise_errorf ~loc:pexp_loc "Invalid string escape sequence") + | _ -> None + +let string_literal_of_payload (x : t) = + match x with + | PStr [{pstr_desc = Pstr_eval (expression, _); _}] -> + string_literal_of_expression expression + | _ -> None + let semantic_string_of_payload (x : t) = match x with | PStr [{pstr_desc = Pstr_eval (expression, _); _}] -> diff --git a/compiler/ml/ast_payload.mli b/compiler/ml/ast_payload.mli index ebaf2636d2..eeea4c43e1 100644 --- a/compiler/ml/ast_payload.mli +++ b/compiler/ml/ast_payload.mli @@ -39,6 +39,11 @@ val semantic_string_of_expression : Parsetree.expression -> string option (** Return the decoded value when the expression is an ordinary string or a non-interpolated backquoted string. *) +val string_literal_of_payload : t -> String_literal.string_literal option +(** Return the string payload of an attribute that denotes a name, keeping its + source spelling. A backquoted payload is given canonical quoted spelling, + since it is the same name written differently. *) + val semantic_string_of_payload : t -> string option (** Return the decoded value of an ordinary or non-interpolated backquoted string. Other prefixed literals, such as [json], are not semantic strings. *) diff --git a/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml index b089964677..ce478b6fb2 100644 --- a/compiler/ml/ast_untagged_variants.ml +++ b/compiler/ml/ast_untagged_variants.ml @@ -339,12 +339,7 @@ let check_tag_field_conflicts (cstrs : Types.constructor_declaration list) = List.iter (fun (field : Types.label_declaration) -> let field_name = Ident.name field.ld_id in - let effective_field_name = - match process_tag_type field.ld_attributes with - | Some (String as_name) -> as_name - (* @as payload types other than string have no effect on record fields *) - | Some _ | None -> field_name - in + let effective_field_name = Record_runtime.declaration_name field in (* Check if effective field name conflicts with tag *) if effective_field_name = effective_tag_name then raise diff --git a/compiler/ml/builtin_attributes.ml b/compiler/ml/builtin_attributes.ml index 9aa5c5756b..dd0a0d5e56 100644 --- a/compiler/ml/builtin_attributes.ml +++ b/compiler/ml/builtin_attributes.ml @@ -147,10 +147,6 @@ let check_deprecated_mutable_inclusion ~def ~use loc attrs1 attrs2 s = Location.deprecated ~def ~use loc (Printf.sprintf "mutating field %s" (cat s txt)) -let check_bs_attributes_inclusion = ref (fun _attrs1 _attrs2 _s -> None) - -let check_duplicated_labels : (_ -> _ option) ref = ref (fun _lbls -> None) - let rec deprecated_of_sig = function | {psig_desc = Psig_attribute a} :: tl -> ( match deprecated_of_attrs [a] with diff --git a/compiler/ml/builtin_attributes.mli b/compiler/ml/builtin_attributes.mli index 63bf762331..b60a13ceb3 100644 --- a/compiler/ml/builtin_attributes.mli +++ b/compiler/ml/builtin_attributes.mli @@ -56,15 +56,6 @@ val check_deprecated_mutable_inclusion : string -> unit -val check_bs_attributes_inclusion : - (Parsetree.attributes -> - Parsetree.attributes -> - string -> - (string * string) option) - ref - -val check_duplicated_labels : - (Parsetree.label_declaration list -> string Asttypes.loc option) ref val error_of_extension : Parsetree.extension -> Location.error val warning_attribute : ?ppwarning:bool -> Parsetree.attribute -> unit diff --git a/compiler/ml/includecore.ml b/compiler/ml/includecore.ml index 577ab77173..026858e565 100644 --- a/compiler/ml/includecore.ml +++ b/compiler/ml/includecore.ml @@ -301,13 +301,11 @@ and compare_records ~loc env params1_ params2_ n_ Builtin_attributes.check_deprecated_mutable_inclusion ~def:ld1.ld_loc ~use:ld2.ld_loc loc ld1.ld_attributes ld2.ld_attributes (Ident.name ld1.ld_id); - let field_mismatch = - !Builtin_attributes.check_bs_attributes_inclusion - ld1.ld_attributes ld2.ld_attributes (Ident.name ld1.ld_id) - in - match field_mismatch with - | Some (a, b) -> [Field_names (n, a, b)] - | None -> + let name1 = Record_runtime.declaration_name ld1 in + let name2 = Record_runtime.declaration_name ld2 in + match name1 <> name2 with + | true -> [Field_names (n, name1, name2)] + | false -> let current_field_consistent = if fast then true else diff --git a/compiler/ml/parsetree.ml b/compiler/ml/parsetree.ml index 3044e9a08b..771714f9cd 100644 --- a/compiler/ml/parsetree.ml +++ b/compiler/ml/parsetree.ml @@ -520,6 +520,12 @@ and type_kind = and label_declaration = { pld_name: string loc; + pld_runtime_name: String_literal.string_literal loc option; + (* The [@as("...")] rename, taken out of the attributes when the field is + built. The attribute is the surface syntax; this is what it means. + The literal keeps its source spelling, and the location is the + attribute's own, so the printer can put it back exactly as it was + written. *) pld_mutable: mutable_flag; pld_optional: bool; pld_type: core_type; diff --git a/compiler/ml/pprintast.ml b/compiler/ml/pprintast.ml index d421bc2b6f..1e108122bc 100644 --- a/compiler/ml/pprintast.ml +++ b/compiler/ml/pprintast.ml @@ -1312,7 +1312,8 @@ and record_declaration ctxt f lbls = let type_record_field f pld = pp f "@[<2>%a%s%a:@;%a@;%a@]" mutable_flag pld.pld_mutable pld.pld_name.txt optional_flag pld.pld_optional (core_type ctxt) pld.pld_type - (attributes ctxt) pld.pld_attributes + (attributes ctxt) + (Ast_helper.Type.field_attributes pld) in pp f "{@\n%a}" (list type_record_field ~sep:";@\n") lbls diff --git a/compiler/ml/predef.ml b/compiler/ml/predef.ml index 3172318eef..6a2414caab 100644 --- a/compiler/ml/predef.ml +++ b/compiler/ml/predef.ml @@ -326,6 +326,7 @@ let common_initial_env add_type add_extension empty_env = ld_id = ident_dict_magic_field_name; ld_attributes = [Dict_type_helpers.dict_magic_field_attr]; ld_loc = Location.none; + ld_runtime_name = None; ld_mutable = Immutable; ld_optional = true; ld_type = newgenty (Tconstr (path_option, [tvar], ref Mnil)); diff --git a/compiler/ml/printast.ml b/compiler/ml/printast.ml index b15cecd6f3..686ccdcd6c 100644 --- a/compiler/ml/printast.ml +++ b/compiler/ml/printast.ml @@ -729,10 +729,9 @@ and constructor_arguments i ppf = function | Pcstr_tuple l -> list i core_type ppf l | Pcstr_record l -> list i label_decl ppf l -and label_decl i ppf {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes} - = +and label_decl i ppf ({pld_name; pld_mutable; pld_type; pld_loc} as ld) = line i ppf "%a\n" fmt_location pld_loc; - attributes i ppf pld_attributes; + attributes i ppf (Ast_helper.Type.field_attributes ld); line (i + 1) ppf "%a\n" fmt_mutable_flag pld_mutable; line (i + 1) ppf "%a" fmt_string_loc pld_name; core_type (i + 1) ppf pld_type diff --git a/compiler/ml/record_coercion.ml b/compiler/ml/record_coercion.ml index 7a9b248f58..7657b7f411 100644 --- a/compiler/ml/record_coercion.ml +++ b/compiler/ml/record_coercion.ml @@ -29,27 +29,16 @@ let check_record_fields (fields1 : Types.label_declaration list) left_optional = ld1.ld_optional; right_optional = ld2.ld_optional; }); - let get_as (({txt}, payload) : Parsetree.attribute) = - if txt = "as" then Ast_payload.semantic_string_of_payload payload - else None - in - let get_as_name (ld : Types.label_declaration) = - match Ext_list.filter_map ld.ld_attributes get_as with - | [] -> None - | s :: _ -> Some s - in - let get_label_runtime_name (ld : Types.label_declaration) = - match get_as_name ld with - | None -> ld.ld_id.name - | Some s -> s - in - if get_label_runtime_name ld1 <> get_label_runtime_name ld2 then + if + Record_runtime.declaration_name ld1 + <> Record_runtime.declaration_name ld2 + then add_violation (Field_runtime_name_mismatch { label = ld1.ld_id.name; - left_as = get_as_name ld1; - right_as = get_as_name ld2; + left_as = ld1.ld_runtime_name; + right_as = ld2.ld_runtime_name; }); (ld1.ld_type :: acc1, ld2.ld_type :: acc2) | None -> diff --git a/compiler/ml/record_runtime.ml b/compiler/ml/record_runtime.ml index af443ca32d..a2103af8ea 100644 --- a/compiler/ml/record_runtime.ml +++ b/compiler/ml/record_runtime.ml @@ -17,11 +17,40 @@ declared with unless an [@as("...")] attribute renames it, and that choice is made once here rather than re-derived wherever a field name is needed. *) -let as_name (({txt}, payload) : Parsetree.attribute) = - if txt = "as" then Ast_payload.semantic_string_of_payload payload else None +let declaration_name (lbl : Types.label_declaration) = + match lbl.ld_runtime_name with + | Some name -> name + | None -> Ident.name lbl.ld_id -let field_name declared_name attributes = - Ext_list.find_def attributes as_name declared_name +(* Two fields collide when they end up with the same runtime name, which a + rename can cause between fields whose declared names differ. *) +let rec check_duplicated_labels_aux (lbls : Parsetree.label_declaration list) + (coll : Set_string.t) = + match lbls with + | [] -> None + | ({pld_name = {txt}} as lbl) :: rest -> ( + if Set_string.mem coll txt && txt <> "..." then Some lbl.pld_name + else + let coll_with_lbl = Set_string.add coll txt in + match lbl.pld_runtime_name with + | None -> check_duplicated_labels_aux rest coll_with_lbl + | Some {txt; loc} -> + let name = String_literal.string_semantic txt in + (* Checked against the fields seen before this one rather than against + [coll_with_lbl], so that [@as("x") x] renames a field to the name it + already has. *) + if Set_string.mem coll name then Some {Asttypes.txt = name; loc} + else + check_duplicated_labels_aux rest (Set_string.add coll_with_lbl name)) -let declaration_name (lbl : Types.label_declaration) = - field_name (Ident.name lbl.ld_id) lbl.ld_attributes +(* A field has one runtime name, so only the first [@as] naming it is taken + out; a second one is left behind and reported here. *) +let extra_as_attribute (lbl : Parsetree.label_declaration) = + Ext_list.find_opt lbl.pld_attributes + (fun (({txt; loc}, payload) : Parsetree.attribute) -> + if txt = "as" && Ast_payload.string_literal_of_payload payload <> None + then Some loc + else None) + +let check_duplicated_labels lbls = + check_duplicated_labels_aux lbls Set_string.empty diff --git a/compiler/ml/record_runtime.mli b/compiler/ml/record_runtime.mli index 73468e136e..dc24d0abea 100644 --- a/compiler/ml/record_runtime.mli +++ b/compiler/ml/record_runtime.mli @@ -15,11 +15,12 @@ (* How a record field is named at run time. *) -val as_name : Parsetree.attribute -> string option -(** The string an [@as("...")] attribute carries, if this is one. *) +val declaration_name : Types.label_declaration -> string -val field_name : string -> Parsetree.attributes -> string -(** The runtime name of a field declared as [declared_name] with [attributes]: - the [@as] payload when there is one, otherwise the declared name. *) +val extra_as_attribute : Parsetree.label_declaration -> Location.t option +(** The location of a second [@as] naming the field, which is one too many. *) -val declaration_name : Types.label_declaration -> string +val check_duplicated_labels : + Parsetree.label_declaration list -> string Asttypes.loc option +(** The first field that collides with an earlier one, by declared or by + runtime name. *) diff --git a/compiler/ml/record_type_spread.ml b/compiler/ml/record_type_spread.ml index fa969bf33d..7e254d0351 100644 --- a/compiler/ml/record_type_spread.ml +++ b/compiler/ml/record_type_spread.ml @@ -114,6 +114,7 @@ let expand_labels_with_type_spreads (env : Env.t) { ld_id = l.ld_id; ld_name = {txt = Ident.name l.ld_id; loc = l.ld_loc}; + ld_runtime_name = l.ld_runtime_name; ld_mutable = l.ld_mutable; ld_optional = l.ld_optional; ld_type = diff --git a/compiler/ml/subst.ml b/compiler/ml/subst.ml index e10b278a26..f7de144a3f 100644 --- a/compiler/ml/subst.ml +++ b/compiler/ml/subst.ml @@ -237,6 +237,7 @@ let typexp = type_expr let label_declaration s l = { ld_id = l.ld_id; + ld_runtime_name = l.ld_runtime_name; ld_mutable = l.ld_mutable; ld_optional = l.ld_optional; ld_type = typexp_rec s l.ld_type; diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index c962a37234..7f6f5fdc3d 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -207,25 +207,36 @@ let make_params env params = List.map make_param params let transl_labels ?record_name env closed lbls = - (match !Builtin_attributes.check_duplicated_labels lbls with + (match Record_runtime.check_duplicated_labels lbls with | None -> () | Some {loc; txt = name} -> raise (Error (loc, Duplicate_label (name, record_name)))); let mk - { - pld_name = name; - pld_mutable = mut; - pld_optional = optional; - pld_type = arg; - pld_loc = loc; - pld_attributes = attrs; - } = + ({ + pld_name = name; + pld_mutable = mut; + pld_optional = optional; + pld_type = arg; + pld_loc = loc; + pld_attributes = attrs; + pld_runtime_name = runtime_name; + } as lbl) = + (match Record_runtime.extra_as_attribute lbl with + | Some loc -> + raise + (Ast_untagged_variants.Error + (loc, Ast_untagged_variants.Duplicated_bs_as)) + | None -> ()); Builtin_attributes.warning_scope attrs (fun () -> let arg = Ast_helper.Typ.force_poly arg in let cty = transl_simple_type env closed arg in { ld_id = Ident.create name.txt; ld_name = name; + ld_runtime_name = + (match runtime_name with + | None -> None + | Some {txt} -> Some (String_literal.string_semantic txt)); ld_mutable = mut; ld_optional = optional; ld_type = cty; @@ -245,6 +256,7 @@ let transl_labels ?record_name env closed lbls = in { Types.ld_id = ld.ld_id; + ld_runtime_name = ld.ld_runtime_name; ld_mutable = ld.ld_mutable; ld_optional = ld.ld_optional; ld_type = ty; @@ -538,6 +550,7 @@ let transl_declaration ~type_record_as_object env sdecl id = ld_id = l.ld_id; ld_name = Location.mkloc (Ident.name l.ld_id) l.ld_loc; + ld_runtime_name = l.ld_runtime_name; ld_mutable = l.ld_mutable; ld_optional = l.ld_optional; ld_type = diff --git a/compiler/ml/typedtree.ml b/compiler/ml/typedtree.ml index e6fecd9210..2c8f1f4a1f 100644 --- a/compiler/ml/typedtree.ml +++ b/compiler/ml/typedtree.ml @@ -401,6 +401,7 @@ and type_kind = and label_declaration = { ld_id: Ident.t; ld_name: string loc; + ld_runtime_name: string option; ld_mutable: mutable_flag; ld_optional: bool; ld_type: core_type; diff --git a/compiler/ml/typedtree.mli b/compiler/ml/typedtree.mli index ab624cf008..6dc342c4ac 100644 --- a/compiler/ml/typedtree.mli +++ b/compiler/ml/typedtree.mli @@ -507,6 +507,7 @@ and type_kind = and label_declaration = { ld_id: Ident.t; ld_name: string loc; + ld_runtime_name: string option; ld_mutable: mutable_flag; ld_optional: bool; ld_type: core_type; diff --git a/compiler/ml/types.ml b/compiler/ml/types.ml index f30e85d68b..98d8adc177 100644 --- a/compiler/ml/types.ml +++ b/compiler/ml/types.ml @@ -166,6 +166,15 @@ and record_representation = and label_declaration = { ld_id: Ident.t; + ld_runtime_name: string option; + (* The name the field has at run time, when it differs from [ld_id]. + Comes from [@as] on the declaration, as its decoded value: two + spellings of one name are one name, so this compares by [=] and is + stable in the cmi. Note the asymmetry with [ld_attributes] below, + which still carries whole parsetree attributes, source spelling + included. That is safe only because every reader of an attribute + payload goes through a semantic accessor; anything comparing + attributes structurally would be comparing keystrokes. *) ld_mutable: mutable_flag; ld_optional: bool; ld_type: type_expr; diff --git a/compiler/ml/types.mli b/compiler/ml/types.mli index 968d0ba812..afd65d485b 100644 --- a/compiler/ml/types.mli +++ b/compiler/ml/types.mli @@ -263,6 +263,15 @@ and record_representation = and label_declaration = { ld_id: Ident.t; + ld_runtime_name: string option; + (* The name the field has at run time, when it differs from [ld_id]. + Comes from [@as] on the declaration, as its decoded value: two + spellings of one name are one name, so this compares by [=] and is + stable in the cmi. Note the asymmetry with [ld_attributes] below, + which still carries whole parsetree attributes, source spelling + included. That is safe only because every reader of an attribute + payload goes through a semantic accessor; anything comparing + attributes structurally would be comparing keystrokes. *) ld_mutable: mutable_flag; ld_optional: bool; ld_type: type_expr; diff --git a/compiler/ml/variant_type_spread.ml b/compiler/ml/variant_type_spread.ml index 08ed7629ce..4034ddc04a 100644 --- a/compiler/ml/variant_type_spread.ml +++ b/compiler/ml/variant_type_spread.ml @@ -174,6 +174,7 @@ let expand_dummy_constructor_args (sdecl_list : Parsetree.type_declaration list) |> List.map (fun (l : Types.label_declaration) -> { Parsetree.pld_name = c.pcd_name; + pld_runtime_name = None; pld_mutable = l.ld_mutable; pld_loc = l.ld_loc; pld_attributes = []; diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index adfb7f34e8..e74bbf5655 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -5220,9 +5220,13 @@ and parse_string_field_declaration p = (* field-decl ::= * | [mutable] field-name : poly-typexpr * | attributes field-decl *) -and parse_field_declaration ?current_type_name_path ?inline_types_context p = +and parse_field_declaration ?current_type_name_path ?inline_types_context + ?(extra_attrs = []) p = let start_pos = p.Parser.start_pos in - let attrs = parse_attributes p in + (* [extra_attrs] are the attributes of the first field, already consumed by + the caller before it knew a record was coming. They go through the same + constructor as the rest so that [@as] is interpreted in one place. *) + let attrs = extra_attrs @ parse_attributes p in let mut = if Parser.optional p Token.Mutable then Asttypes.Mutable else Asttypes.Immutable @@ -5508,10 +5512,7 @@ and parse_constr_decl_args p = parse_comma_delimited_region ~grammar:Grammar.FieldDeclarations ~closing:Rbrace ~f:parse_field_declaration_region p | attrs -> - let first = - let field = parse_field_declaration p in - {field with Parsetree.pld_attributes = attrs} - in + let first = parse_field_declaration ~extra_attrs:attrs p in if p.token = Rbrace then [first] else ( Parser.expect Comma p; @@ -6049,17 +6050,13 @@ and parse_record_or_object_decl ?current_type_name_path ?inline_types_context p let first = let field = parse_field_declaration ?current_type_name_path - ?inline_types_context p + ?inline_types_context ~extra_attrs:attrs p in Parser.optional p Comma |> ignore; { field with - Parsetree.pld_attributes = attrs; - pld_loc = - { - field.Parsetree.pld_loc with - loc_start = (attr |> fst).loc.loc_start; - }; + Parsetree.pld_loc = + {field.pld_loc with loc_start = (attr |> fst).loc.loc_start}; } in first diff --git a/compiler/syntax/src/res_printer.ml b/compiler/syntax/src/res_printer.ml index 35b5087f2a..f9f3ecdb20 100644 --- a/compiler/syntax/src/res_printer.ml +++ b/compiler/syntax/src/res_printer.ml @@ -1867,7 +1867,11 @@ and print_constructor_arguments ?(is_dot_dot_dot = false) ~state ~indent and print_label_declaration ?inline_record_definitions ~state (ld : Parsetree.label_declaration) cmt_tbl = let attrs = - print_attributes ~state ~loc:ld.pld_name.loc ld.pld_attributes cmt_tbl + (* The runtime name is held as a field rather than an attribute, so put its + surface syntax back. *) + print_attributes ~state ~loc:ld.pld_name.loc + (Ast_helper.Type.field_attributes ld) + cmt_tbl in let mutable_flag = match ld.pld_mutable with diff --git a/tests/analysis_tests/tests/src/CompletionAttributes.res b/tests/analysis_tests/tests/src/CompletionAttributes.res index 674580a9eb..31d13b6508 100644 --- a/tests/analysis_tests/tests/src/CompletionAttributes.res +++ b/tests/analysis_tests/tests/src/CompletionAttributes.res @@ -37,3 +37,5 @@ // let dd = %t // ^com +// type withAs = {@as("wire") a: int} +// ^com diff --git a/tests/analysis_tests/tests/src/expected/CompletionAttributes.res.txt b/tests/analysis_tests/tests/src/expected/CompletionAttributes.res.txt index 926cde0dcc..bd93a11e81 100644 --- a/tests/analysis_tests/tests/src/expected/CompletionAttributes.res.txt +++ b/tests/analysis_tests/tests/src/expected/CompletionAttributes.res.txt @@ -275,3 +275,23 @@ Resolved opens 1 Stdlib } ] +Complete src/CompletionAttributes.res 39:21 +Attribute id:as:[39:18->39:21] label:as +Completable: Cdecorator(as) +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +[ + { + "detail": "", + "documentation": { + "kind": "markdown", + "value": "The `@as` decorator is commonly used on record types to alias record field names to a different JavaScript attribute name.\n\nThis is useful to map to JavaScript attribute names that cannot be expressed in ReScript (such as keywords).\n\nIt is also possible to map a ReScript record to a JavaScript array by passing indices to the `@as` decorator.\n\n[Read more and see examples in the documentation](https://rescript-lang.org/syntax-lookup#as-decorator)." + }, + "insertText": "as(\"$0\")", + "insertTextFormat": 2, + "kind": 4, + "label": "as", + "tags": [] + } +] + diff --git a/tests/ounit_tests/ounit_ast_mapper0_tests.ml b/tests/ounit_tests/ounit_ast_mapper0_tests.ml index 32e2564b04..77dbd7ae96 100644 --- a/tests/ounit_tests/ounit_ast_mapper0_tests.ml +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -76,6 +76,90 @@ let test_record_rest_roundtrips_through_ast0 _ = () | _ -> assert_failure "Expected record rest after ast0 roundtrip" +(* The ast-mapping fixtures show that a field's [@as] survives the roundtrip. + What they cannot show is the shape it travels in: an external ppx reads the + frozen AST, so the runtime name has to reach it as an ordinary [@as] + attribute and not under some name of the bridge's own choosing. *) +let test_field_runtime_name_reaches_ast0_as_an_attribute _ = + let as_attr = + attr "as" + (Parsetree.PStr + [ + Ast_helper.Str.eval + (Ast_helper.Exp.constant + (Pconst_string (String_literal.string_from_semantic "renamed"))); + ]) + in + let field = + Ast_helper.Type.field ~loc ~attrs:[as_attr] (located_string "a") + (Ast_helper.Typ.constr ~loc (located_string (Longident.Lident "int")) []) + in + OUnit.assert_bool "Expected the @as attribute to become the field" + (field.pld_runtime_name <> None); + let field0 = + Ast_mapper_to0.default_mapper.label_declaration + Ast_mapper_to0.default_mapper field + in + OUnit.assert_bool "Expected a plain @as attribute on the ast0 wire" + (has_attr "as" field0.pld_attributes) + +(* A ppx reads the attribute list in order, so the one taken out has to go back + where it was written rather than at the front. *) +(* Ppx output carries no source position, so every attribute ties. The rename + goes back last among them, the order a ppx writing [@dead @as("x")] gave. *) +let test_field_runtime_name_keeps_ppx_order_on_the_wire _ = + let field = + Ast_helper.Type.field ~loc:Location.none + ~attrs: + [ + (Location.mknoloc "dead", Parsetree.PStr []); + ( Location.mknoloc "as", + Parsetree.PStr + [ + Ast_helper.Str.eval + (Ast_helper.Exp.constant + (Pconst_string (String_literal.string_from_semantic "wire"))); + ] ); + ] + (Location.mknoloc "a") + (Ast_helper.Typ.constr (Location.mknoloc (Longident.Lident "int")) []) + in + let field0 = + Ast_mapper_to0.default_mapper.label_declaration + Ast_mapper_to0.default_mapper field + in + OUnit.assert_equal ~printer:(String.concat ", ") ["dead"; "as"] + (List.map + (fun (({txt} : string Asttypes.loc), _) -> txt) + field0.pld_attributes) + +let test_field_runtime_name_keeps_its_place_on_the_wire _ = + let earlier = source_loc 10 20 and as_loc = source_loc 30 40 in + let field = + Ast_helper.Type.field ~loc + ~attrs: + [ + (located_string ~loc:earlier "dead", Parsetree.PStr []); + ( located_string ~loc:as_loc "as", + Parsetree.PStr + [ + Ast_helper.Str.eval + (Ast_helper.Exp.constant + (Pconst_string (String_literal.string_from_semantic "wire"))); + ] ); + ] + (located_string "a") + (Ast_helper.Typ.constr ~loc (located_string (Longident.Lident "int")) []) + in + let field0 = + Ast_mapper_to0.default_mapper.label_declaration + Ast_mapper_to0.default_mapper field + in + OUnit.assert_equal ~printer:(String.concat ", ") ["dead"; "as"] + (List.map + (fun (({txt} : string Asttypes.loc), _) -> txt) + field0.pld_attributes) + let map_expr0 e = Ast_mapper_from0.default_mapper.expr Ast_mapper_from0.default_mapper e @@ -709,4 +793,10 @@ let suites = >:: test_function_cases_desugar_to_fun_match; "error_extensions_accept_backquoted_strings" >:: test_error_extension_backquoted_strings; + "field_runtime_name_reaches_ast0_as_an_attribute" + >:: test_field_runtime_name_reaches_ast0_as_an_attribute; + "field_runtime_name_keeps_its_place_on_the_wire" + >:: test_field_runtime_name_keeps_its_place_on_the_wire; + "field_runtime_name_keeps_ppx_order_on_the_wire" + >:: test_field_runtime_name_keeps_ppx_order_on_the_wire; ] diff --git a/tests/syntax_tests/data/ast-mapping/RecordFieldNames.res b/tests/syntax_tests/data/ast-mapping/RecordFieldNames.res new file mode 100644 index 0000000000..158ddc6cf6 --- /dev/null +++ b/tests/syntax_tests/data/ast-mapping/RecordFieldNames.res @@ -0,0 +1,20 @@ +type renamed = {@as("b") a: int, b2: int} + +type escaped = {@as("a\nb\"c") x: int} + +/* A spelling that is not the canonical one for its value. The parsetree keeps + the literal's source, so printing must give back what was written rather + than "A". */ +type nonCanonical = {@as("\u0041") w: int} + +type backquoted = {@as(`tick`) y: int} + +type notAName = {@as(42) z: int} + +type twoNames = {@as("d1") @as("d2") d: int} + +type ordered = {@dead("x") @as("m2") m: int} + +type optionalToo = {@as("o2") o?: int} + +type inInlineRecord = User({@as("renamed") name: string, age: int}) diff --git a/tests/syntax_tests/data/ast-mapping/expected/RecordFieldNames.res.txt b/tests/syntax_tests/data/ast-mapping/expected/RecordFieldNames.res.txt new file mode 100644 index 0000000000..7c658f0ae3 --- /dev/null +++ b/tests/syntax_tests/data/ast-mapping/expected/RecordFieldNames.res.txt @@ -0,0 +1,20 @@ +type renamed = {@as("b") a: int, b2: int} + +type escaped = {@as("a\nb\"c") x: int} + +/* A spelling that is not the canonical one for its value. The parsetree keeps + the literal's source, so printing must give back what was written rather + than "A". */ +type nonCanonical = {@as("\u0041") w: int} + +type backquoted = {@as("tick") y: int} + +type notAName = {@as(42) z: int} + +type twoNames = {@as("d1") @as("d2") d: int} + +type ordered = {@dead("x") @as("m2") m: int} + +type optionalToo = {@as("o2") o?: int} + +type inInlineRecord = User({@as("renamed") name: string, age: int}) diff --git a/tests/tests/src/record_field_as_spelling_test.mjs b/tests/tests/src/record_field_as_spelling_test.mjs new file mode 100644 index 0000000000..fa56acffa3 --- /dev/null +++ b/tests/tests/src/record_field_as_spelling_test.mjs @@ -0,0 +1,21 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + + +function getA(x) { + return x.A; +} + +let Renamed_v = { + A: 1, + b: 2 +}; + +let Renamed = { + v: Renamed_v, + getA: getA +}; + +export { + Renamed, +} +/* No side effect */ diff --git a/tests/tests/src/record_field_as_spelling_test.res b/tests/tests/src/record_field_as_spelling_test.res new file mode 100644 index 0000000000..fe55fee714 --- /dev/null +++ b/tests/tests/src/record_field_as_spelling_test.res @@ -0,0 +1,16 @@ +/* A record field's runtime name is its decoded value, not the way it was + spelled. The signature spells the same name with a unicode escape, so the + two describe one field and the constraint is satisfied. */ +module Renamed: { + type t = {@as("\u0041") a: int, b: int} + + let v: t + + let getA: t => int +} = { + type t = {@as("A") a: int, b: int} + + let v = {a: 1, b: 2} + + let getA = (x: t) => x.a +} From ab50d5da4b11e5e11e593da9f3d5d31a2793cba1 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Thu, 3 Sep 2026 17:00:59 +0200 Subject: [PATCH 04/10] Make @as on a variant constructor part of the AST Following the same move for record fields, a constructor's @as runtime tag is now recorded on the declaration instead of being re-interpreted from its attributes. Extraction happens in Ast_helper.Type.constructor, so the parser, every ppx and the frozen-AST bridge inherit it, and ast_mapper_to0 puts the attribute back the way it does for records. The parsetree keeps the payload's source spelling, so @as(0xA) and @as("A") print back as written rather than as 10 and "A". The typed declaration keeps only the decoded tag. This deletes process_tag_type, which decoded the same attribute a second time, and with it four payload readers that had no other caller. has_undefined_literal was dead. constructor_tag and block_runtime took an attribute list that every caller passed empty, since they build tags for constructors the compiler generates itself, so they now say that. An out-of-range integer in @as used to abort the compiler with Failure("int_of_string"); it now reports its own error at the annotation. Signed-off-by: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- CHANGELOG.md | 4 +- analysis/src/completion_front_end.ml | 11 +++ compiler/core/lam_compile_primitive.ml | 2 +- compiler/ext/config.ml | 8 +- compiler/frontend/bs_ast_invariant.ml | 5 +- compiler/ml/ast_helper.ml | 54 ++++++++++- compiler/ml/ast_helper.mli | 6 ++ compiler/ml/ast_mapper.ml | 4 +- compiler/ml/ast_mapper_to0.ml | 5 +- compiler/ml/ast_payload.ml | 27 +++++- compiler/ml/ast_payload.mli | 9 +- compiler/ml/ast_untagged_variants.ml | 91 ++++++++++--------- compiler/ml/parsetree.ml | 13 +++ compiler/ml/pprintast.ml | 5 +- compiler/ml/predef.ml | 2 + compiler/ml/printast.ml | 5 +- compiler/ml/subst.ml | 1 + compiler/ml/transl_recmodule.ml | 6 +- compiler/ml/typedecl.ml | 4 + compiler/ml/typedtree.ml | 1 + compiler/ml/typedtree.mli | 1 + compiler/ml/types.ml | 3 + compiler/ml/types.mli | 2 + compiler/ml/variant_layout.ml | 13 ++- compiler/ml/variant_runtime.ml | 21 +++++ compiler/ml/variant_runtime.mli | 13 +++ compiler/ml/variant_type_spread.ml | 9 ++ compiler/syntax/src/res_ast_debugger.ml | 2 +- compiler/syntax/src/res_printer.ml | 5 +- tests/ERROR_VARIANTS.md | 1 + .../tests/src/CompletionAttributes.res | 3 + .../src/expected/CompletionAttributes.res.txt | 20 ++++ .../VariantAsIntegerOutOfRange.res.expected | 8 ++ .../fixtures/VariantAsIntegerOutOfRange.res | 1 + tests/ounit_tests/ounit_ast_mapper0_tests.ml | 23 +++++ .../ast-mapping/VariantConstructorTags.res | 26 ++++++ .../expected/VariantConstructorTags.res.txt | 26 ++++++ .../variant_constructor_as_spelling_test.mjs | 11 +++ .../variant_constructor_as_spelling_test.res | 11 +++ 39 files changed, 386 insertions(+), 76 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/VariantAsIntegerOutOfRange.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/VariantAsIntegerOutOfRange.res create mode 100644 tests/syntax_tests/data/ast-mapping/VariantConstructorTags.res create mode 100644 tests/syntax_tests/data/ast-mapping/expected/VariantConstructorTags.res.txt create mode 100644 tests/tests/src/variant_constructor_as_spelling_test.mjs create mode 100644 tests/tests/src/variant_constructor_as_spelling_test.res diff --git a/CHANGELOG.md b/CHANGELOG.md index 1ec967e4db..036e81aa3f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -38,6 +38,7 @@ - Fix the side-effect analysis treating bigint exponentiation and bounds-checked array and string reads as pure, which let dead-code elimination drop an unused one that throws: `let _ = 2n ** -1n` no longer raised. https://github.com/rescript-lang/rescript/pull/8617 - Fix excessive parentheses and indentation in function assignments to refs, align record and array assignment formatting across refs and fields, and preserve function return-type parentheses and consistent JSX fragment layout in callbacks. https://github.com/rescript-lang/rescript/pull/8611 +- Report an error instead of crashing when an integer in a variant constructor's `@as` annotation exceeds the compiler's integer range. https://github.com/rescript-lang/rescript/pull/8619 - Fix a recursive module with an empty signature discarding its right-hand side. Lambda-to-Lam conversion rewrote `Pupdate_mod` to unit when the module's shape had no fields, dropping the primitive's arguments - one of which is the right-hand side - so `module rec M: {} = { let () = Console.log("effect") }` emitted nothing for `M`. The elision now happens where the bindings are produced, with the right-hand side still in hand. https://github.com/rescript-lang/rescript/pull/8608 - Fix a compiler crash on a polymorphic variant whose numeric name exceeds the `int32` range. `#99999999999("a")` and the same name in a pattern failed with `Failure("Int32.of_string")` and no location, because the range check ran in the frontend AST pass and matched only payload-free expressions. It now runs in `Typecore`, next to the integer literal decoding whose overflow error it mirrors, and covers both label positions. A bare `type t = [#99999999999]` still compiles, since nothing decodes a row field name. https://github.com/rescript-lang/rescript/pull/8608 - Object typing errors now describe fields directly: assigning to a field without `@set` reports that the field is not settable and suggests the annotation, and missing-property errors name the field instead of a phantom `"x#="` member. https://github.com/rescript-lang/rescript/pull/8597 @@ -66,7 +67,7 @@ - Print external declarations in signatures and type errors with their processed attributes instead of the `"#rescript-external"` placeholder, and print inline constants using `@inline` syntax. https://github.com/rescript-lang/rescript/pull/8581 - Improve diagnostics for dynamic imports of local values and attempts to use `import` as a first-class value. https://github.com/rescript-lang/rescript/pull/8582 - Allow inferred labeled functions to be called with labels in any order by removing legacy curried-arrow commutation locks. https://github.com/rescript-lang/rescript/pull/8547 -- Format a record field's `@as` rename written as a backquoted string with ordinary quotes, since it names the same field either way. https://github.com/rescript-lang/rescript/pull/NNNN +- Format an `@as` payload written as a backquoted string with ordinary quotes, on both record fields and variant constructors, since it names the same thing either way. https://github.com/rescript-lang/rescript/pull/8619 #### :house: Internal @@ -74,6 +75,7 @@ - Replace non-escaping local mutable blocks with scalar bindings when all uses are direct field accesses, generalizing reference unboxing to multi-field records and references captured by JavaScript closures. https://github.com/rescript-lang/rescript/pull/8617 - Split `lambda.ml` into the IR and its traversals, static exits and path translation, so the module defining `Lambda.t` no longer reaches into `Env` or `Path`. https://github.com/rescript-lang/rescript/pull/8618 - Record a record field's `@as` rename on the declaration instead of re-reading the attribute, so every place that needs the runtime name reads one field. https://github.com/rescript-lang/rescript/pull/8619 +- Record a variant constructor's `@as` tag on the declaration instead of re-interpreting its attributes, keeping the source spelling for printing. https://github.com/rescript-lang/rescript/pull/8619 - Merge the duplicate Lam intermediate representation into Lambda, removing the conversion layer and obsolete supporting infrastructure. Lambda is now a single private, normalized representation, with generated JavaScript remaining semantically unchanged. https://github.com/rescript-lang/rescript/pull/8608 - Add genType and source map controls and output to the developer playground. https://github.com/rescript-lang/rescript/pull/8448 - Rework the object-type representation end to end: object rows are plain field chains carrying a per-field mutability state (no phantom setter members), object literals are typed directly and property access and assignment are first-class AST and Lambda nodes shared between the Lambda and JS pipelines, and dead class-system remnants (the field-presence lattice, the class-abbreviation memo on object types, method-send typing) are removed. https://github.com/rescript-lang/rescript/pull/8597 diff --git a/analysis/src/completion_front_end.ml b/analysis/src/completion_front_end.ml index 3356797ca8..d7bcb56821 100644 --- a/analysis/src/completion_front_end.ml +++ b/analysis/src/completion_front_end.ml @@ -1860,10 +1860,21 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file Ast_iterator.default_iterator.label_declaration iterator ld in + let constructor_declaration (iterator : Ast_iterator.iterator) + (cd : Parsetree.constructor_declaration) = + (match cd.pcd_runtime_tag with + | Some {loc} + when (not loc.loc_ghost) && Loc.has_pos loc ~pos:pos_before_cursor -> + decorator_at ~id_txt:"as" loc + | _ -> ()); + Ast_iterator.default_iterator.constructor_declaration iterator cd + in + let iterator = { Ast_iterator.default_iterator with attribute; + constructor_declaration; expr; label_declaration; location; diff --git a/compiler/core/lam_compile_primitive.ml b/compiler/core/lam_compile_primitive.ml index 6b3fe8462d..71b06a9a61 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -567,7 +567,7 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) { name = "::"; num_nonconst = 1; - runtime = Ast_untagged_variants.block_runtime ~name:"::" []; + runtime = Ast_untagged_variants.generated_block_runtime ~name:"::"; }) args | Pmakedict -> ( diff --git a/compiler/ext/config.ml b/compiler/ext/config.ml index 1a187acfa8..dec9d67d4d 100644 --- a/compiler/ext/config.ml +++ b/compiler/ext/config.ml @@ -1,10 +1,10 @@ -let cmi_magic_number = "Caml1999I031" +let cmi_magic_number = "Caml1999I032" (* Magic numbers for marshaled values of the *current* parsetree, whose layout changes across compiler versions. *) -and ast_impl_magic_number = "ResImpl01305" +and ast_impl_magic_number = "ResImpl01306" -and ast_intf_magic_number = "ResIntf01305" +and ast_intf_magic_number = "ResIntf01306" (* Magic numbers of the frozen Parsetree0 (OCaml 4.06) layout used on the external-PPX wire. They must never be written in front of a @@ -13,6 +13,6 @@ and ast0_impl_magic_number = "Caml1999M022" and ast0_intf_magic_number = "Caml1999N022" -and cmt_magic_number = "Caml1999T033" +and cmt_magic_number = "Caml1999T034" let load_path = ref ([] : string list) diff --git a/compiler/frontend/bs_ast_invariant.ml b/compiler/frontend/bs_ast_invariant.ml index 6aaf07f2a7..bc661a4b88 100644 --- a/compiler/frontend/bs_ast_invariant.ml +++ b/compiler/frontend/bs_ast_invariant.ml @@ -101,10 +101,7 @@ let emit_external_warnings : iterator = super.label_declaration self lbl); constructor_declaration = (fun self ({pcd_name = {txt; loc}} as ctr) -> - let _ = - Ast_untagged_variants.process_tag_type - ctr.pcd_attributes (* mark @as used in variant cases *) - in + ignore (Ast_untagged_variants.process_constructor_tag ctr); (match txt with | "false" | "true" | "()" -> Location.raise_errorf ~loc "%s can not be redefined " txt diff --git a/compiler/ml/ast_helper.ml b/compiler/ml/ast_helper.ml index db191ff1ab..8c3bb97b0a 100644 --- a/compiler/ml/ast_helper.ml +++ b/compiler/ml/ast_helper.ml @@ -391,15 +391,67 @@ module Type = struct } let constructor ?(loc = !default_loc) ?(attrs = []) ?(args = Pcstr_tuple []) - ?res name = + ?res ?runtime_tag name = + let runtime_tag, attrs = + match runtime_tag with + | Some tag -> (Some {Asttypes.txt = tag; loc = name.loc}, attrs) + | None -> ( + (* Only the first [@as] can name the constructor. Leave an invalid + first annotation, and everything after it, for the type checker so + formatting an invalid file does not change its diagnostics. *) + let rec take seen (attrs : Parsetree.attributes) = + match attrs with + | [] -> (None, []) + | (({txt = "as"; loc}, payload) : Parsetree.attribute) :: rest -> ( + match Ast_payload.constructor_tag_of_payload payload with + | Some txt -> (Some {Asttypes.txt; loc}, List.rev_append seen rest) + | None -> (None, attrs)) + | attr :: rest -> take (attr :: seen) rest + in + match take [] attrs with + | None, _ -> (None, attrs) + | found -> found) + in { pcd_name = name; + pcd_runtime_tag = runtime_tag; pcd_args = args; pcd_res = res; pcd_loc = loc; pcd_attributes = attrs; } + let constructor_attributes (cd : Parsetree.constructor_declaration) = + match cd.pcd_runtime_tag with + | None -> cd.pcd_attributes + | Some {txt = tag; loc} -> + let expression = + match tag with + | Pct_string s -> Exp.constant ~loc (Pconst_string s) + | Pct_int i -> Exp.constant ~loc (Pconst_integer (i, None)) + | Pct_float f -> Exp.constant ~loc (Pconst_float (f, None)) + | Pct_bigint i -> Exp.constant ~loc (Pconst_integer (i, Some 'n')) + | Pct_bool b -> + Exp.construct ~loc + (Location.mkloc + (Longident.Lident (if b then "true" else "false")) + loc) + None + | Pct_null -> + Exp.ident ~loc (Location.mkloc (Longident.Lident "null") loc) + | Pct_undefined -> + Exp.ident ~loc (Location.mkloc (Longident.Lident "undefined") loc) + in + let payload = Parsetree.PStr [Str.eval ~loc expression] in + (* Back where it was written, so attributes print in source order. Ppx + output has no source position and ties, as for a field's rename + above; the tag goes last among the tied. *) + let written_earlier (({loc = other}, _) : Parsetree.attribute) = + other.loc_start.pos_cnum <= loc.loc_start.pos_cnum + in + let earlier, later = List.partition written_earlier cd.pcd_attributes in + earlier @ ((Location.mkloc "as" loc, payload) :: later) + (* [@as("x")] on a record field renames it at run time. It is taken out of the attributes here, so every producer - the parser, a ppx, the frozen AST bridge - agrees on what the field is called without re-reading the diff --git a/compiler/ml/ast_helper.mli b/compiler/ml/ast_helper.mli index 5b7ccc186c..7cb4a7104c 100644 --- a/compiler/ml/ast_helper.mli +++ b/compiler/ml/ast_helper.mli @@ -295,8 +295,14 @@ module Type : sig ?attrs:attrs -> ?args:constructor_arguments -> ?res:core_type -> + ?runtime_tag:constructor_tag -> str -> constructor_declaration + (** A valid first [@as] in [attrs] is taken out and becomes the runtime tag, + unless one is given explicitly. *) + + val constructor_attributes : constructor_declaration -> attrs + (** The attributes as written, with the constructor [@as] put back. *) val field : ?loc:loc -> diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index 2e888c0ac6..327a805ebc 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -527,12 +527,12 @@ let default_mapper = ~loc:(this.location this pvb_loc) ~attrs:(this.attributes this pvb_attributes)); constructor_declaration = - (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> + (fun this ({pcd_name; pcd_args; pcd_res; pcd_loc} as cd) -> Type.constructor (map_loc this pcd_name) ~args:(T.map_constructor_arguments this pcd_args) ?res:(map_opt (this.typ this) pcd_res) ~loc:(this.location this pcd_loc) - ~attrs:(this.attributes this pcd_attributes)); + ~attrs:(this.attributes this (Type.constructor_attributes cd))); label_declaration = (fun this ({pld_name; pld_type; pld_loc; pld_mutable; pld_optional} as ld) diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index 1cbc1d2bd4..b2a6f5c66a 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -924,12 +924,13 @@ let default_mapper = in Vb.mk pvb_pat pvb_expr ~loc ~attrs:(this.attributes this pvb_attributes)); constructor_declaration = - (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> + (fun this ({pcd_name; pcd_args; pcd_res; pcd_loc} as cd) -> Type.constructor (map_loc this pcd_name) ~args:(T.map_constructor_arguments this pcd_args) ?res:(map_opt (this.typ this) pcd_res) ~loc:(this.location this pcd_loc) - ~attrs:(this.attributes this pcd_attributes)); + ~attrs: + (this.attributes this (Ast_helper.Type.constructor_attributes cd))); label_declaration = (fun this ({pld_name; pld_type; pld_loc; pld_mutable; pld_optional} as ld) diff --git a/compiler/ml/ast_payload.ml b/compiler/ml/ast_payload.ml index 9f1a16656e..649bb0526b 100644 --- a/compiler/ml/ast_payload.ml +++ b/compiler/ml/ast_payload.ml @@ -82,7 +82,7 @@ let semantic_string_of_payload (x : t) = semantic_string_of_expression expression | _ -> None -let is_single_int (x : t) : int option = +let single_int_source (x : t) = match x with | PStr [ @@ -96,9 +96,11 @@ let is_single_int (x : t) : int option = when match char with | Some n when n = 'n' -> false | _ -> true -> - Some (int_of_string name) + Some name | _ -> None +let is_single_int x = Option.map int_of_string (single_int_source x) + let is_single_float (x : t) : string option = match x with | PStr @@ -153,6 +155,27 @@ let is_single_ident (x : t) = Some lid.txt | _ -> None +let constructor_tag_of_payload payload = + match string_literal_of_payload payload with + | Some s -> Some (Parsetree.Pct_string s) + | None -> ( + match single_int_source payload with + | Some i -> Some (Pct_int i) + | None -> ( + match is_single_float payload with + | Some f -> Some (Pct_float f) + | None -> ( + match is_single_bigint payload with + | Some i -> Some (Pct_bigint i) + | None -> ( + match is_single_bool payload with + | Some b -> Some (Pct_bool b) + | None -> ( + match is_single_ident payload with + | Some (Lident "null") -> Some Pct_null + | Some (Lident "undefined") -> Some Pct_undefined + | Some _ | None -> None))))) + let raw_as_string_exp_exn ~(kind : Js_raw_info.raw_kind) ?is_function (x : t) : Parsetree.expression option = let string_expression = diff --git a/compiler/ml/ast_payload.mli b/compiler/ml/ast_payload.mli index eeea4c43e1..40a740ddcf 100644 --- a/compiler/ml/ast_payload.mli +++ b/compiler/ml/ast_payload.mli @@ -50,13 +50,8 @@ val semantic_string_of_payload : t -> string option val is_single_int : t -> int option -val is_single_float : t -> string option - -val is_single_bigint : t -> string option - -val is_single_bool : t -> bool option - -val is_single_ident : t -> Longident.t option +val constructor_tag_of_payload : t -> Parsetree.constructor_tag option +(** The literal denoted by a valid variant-constructor [@as] payload. *) val raw_as_string_exp_exn : kind:Js_raw_info.raw_kind -> diff --git a/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml index ce478b6fb2..582c54d234 100644 --- a/compiler/ml/ast_untagged_variants.ml +++ b/compiler/ml/ast_untagged_variants.ml @@ -13,6 +13,7 @@ type untagged_error = | ConstructorMoreThanOneArg of string type error = | InvalidVariantAsAnnotation + | VariantAsIntegerOutOfRange of string | Duplicated_bs_as | InvalidVariantTagAnnotation | InvalidUntaggedVariantDefinition of untagged_error @@ -26,6 +27,10 @@ let report_error ppf = fprintf ppf "A variant case annotation @as(...) must be a string, integer, boolean, \ null, or undefined." + | VariantAsIntegerOutOfRange value -> + fprintf ppf + "The integer %s in this variant case's @as annotation is out of range." + value | Duplicated_bs_as -> fprintf ppf "Duplicate @as annotation; only one @as is allowed here." | InvalidVariantTagAnnotation -> @@ -110,37 +115,42 @@ let process_untagged (attrs : Parsetree.attributes) = | _ -> ()); !st -let process_tag_type (attrs : Parsetree.attributes) = - let st : tag_type option ref = ref None in - Ext_list.iter attrs (fun (({txt; loc}, payload) as attr) -> - match txt with - | "as" -> - if !st = None then ( - (match Ast_payload.semantic_string_of_payload payload with - | None -> () - | Some s -> st := Some (String s)); - (match Ast_payload.is_single_int payload with - | None -> () - | Some i -> st := Some (Int i)); - (match Ast_payload.is_single_float payload with - | None -> () - | Some f -> st := Some (Float f)); - (match Ast_payload.is_single_bigint payload with - | None -> () - | Some i -> st := Some (BigInt i)); - (match Ast_payload.is_single_bool payload with - | None -> () - | Some b -> st := Some (Bool b)); - (match Ast_payload.is_single_ident payload with - | None -> () - | Some (Lident "null") -> st := Some Null - | Some (Lident "undefined") -> st := Some Undefined - | Some _ -> raise (Error (loc, InvalidVariantAsAnnotation))); - if !st = None then raise (Error (loc, InvalidVariantAsAnnotation)) - else Used_attributes.mark_used_attribute attr) - else raise (Error (loc, Duplicated_bs_as)) - | _ -> ()); - !st +let runtime_tag_of_parsetree ~loc = function + | Parsetree.Pct_string s -> Declared_string (String_literal.string_semantic s) + | Pct_int source -> ( + match int_of_string_opt source with + | Some i -> Declared_int i + | None -> raise (Error (loc, VariantAsIntegerOutOfRange source))) + | Pct_float f -> Declared_float f + | Pct_bigint i -> Declared_bigint i + | Pct_bool b -> Declared_bool b + | Pct_null -> Declared_null + | Pct_undefined -> Declared_undefined + +let parsetree_tag_of_runtime = function + | Declared_string s -> + Parsetree.Pct_string (String_literal.string_from_semantic s) + | Declared_int i -> Pct_int (string_of_int i) + | Declared_float f -> Pct_float f + | Declared_bigint i -> Pct_bigint i + | Declared_bool b -> Pct_bool b + | Declared_null -> Pct_null + | Declared_undefined -> Pct_undefined + +(* An [@as] left in the attributes did not name the constructor: either its + payload is not a tag, or an earlier [@as] already named it. *) +let reject_leftover_as (attrs : Parsetree.attributes) err = + Ext_list.iter attrs (fun (({txt; loc}, _) : Parsetree.attribute) -> + if txt = "as" then raise (Error (loc, err))) + +let process_constructor_tag (cstr : Parsetree.constructor_declaration) = + match cstr.pcd_runtime_tag with + | None -> + reject_leftover_as cstr.pcd_attributes InvalidVariantAsAnnotation; + None + | Some {txt; loc} -> + reject_leftover_as cstr.pcd_attributes Duplicated_bs_as; + Some (runtime_tag_of_parsetree ~loc txt) let () = Location.register_error_of_exn (function @@ -209,14 +219,11 @@ let process_tag_name (attrs : Parsetree.attributes) = let get_tag_name (cstr : Types.constructor_declaration) = process_tag_name cstr.cd_attributes -let constructor_tag ~name attrs = {name; tag_type = process_tag_type attrs} +(* A constructor the compiler generates itself carries no annotations. *) +let generated_tag ~name = {name; tag_type = None} -let block_runtime ~name attrs = - { - tag = constructor_tag ~name attrs; - tag_name = process_tag_name attrs; - untagged = process_untagged attrs; - } +let generated_block_runtime ~name = + {tag = generated_tag ~name; tag_name = None; untagged = false} let is_nullary_variant (x : Types.constructor_arguments) = match x with @@ -323,7 +330,11 @@ let check_invariant ~is_untagged_def ~(consts : (Location.t * tag) list) check_literal ~is_const:false ~loc block.runtime.tag) let get_cstr_loc_tag (cstr : Types.constructor_declaration) = - (cstr.cd_loc, constructor_tag ~name:(Ident.name cstr.cd_id) cstr.cd_attributes) + ( cstr.cd_loc, + { + name = Ident.name cstr.cd_id; + tag_type = Option.map tag_type_of_declared cstr.cd_runtime_tag; + } ) let check_tag_field_conflicts (cstrs : Types.constructor_declaration list) = List.iter @@ -351,8 +362,6 @@ let check_tag_field_conflicts (cstrs : Types.constructor_declaration list) = | _ -> ()) cstrs -let has_undefined_literal attrs = process_tag_type attrs = Some Undefined - module Dynamic_checks = struct type op = EqEqEq | NotEqEq | Or | And type 'a t = diff --git a/compiler/ml/parsetree.ml b/compiler/ml/parsetree.ml index 771714f9cd..daccd0f858 100644 --- a/compiler/ml/parsetree.ml +++ b/compiler/ml/parsetree.ml @@ -540,12 +540,25 @@ and label_declaration = { *) and constructor_declaration = { pcd_name: string loc; + pcd_runtime_tag: constructor_tag loc option; + (* The [@as(...)] runtime tag, taken out of the attributes when the + constructor is built. The literal retains the source information + needed to print the attribute back where it was written. *) pcd_args: constructor_arguments; pcd_res: core_type option; pcd_loc: Location.t; pcd_attributes: attributes; (* C of ... [@id1] [@id2] *) } +and constructor_tag = + | Pct_string of String_literal.string_literal + | Pct_int of string + | Pct_float of string + | Pct_bigint of string + | Pct_bool of bool + | Pct_null + | Pct_undefined + and constructor_arguments = | Pcstr_tuple of core_type list | Pcstr_record of label_declaration list diff --git a/compiler/ml/pprintast.ml b/compiler/ml/pprintast.ml index 1e108122bc..180e7184d2 100644 --- a/compiler/ml/pprintast.ml +++ b/compiler/ml/pprintast.ml @@ -1336,7 +1336,10 @@ and type_declaration ctxt f x = let constructor_declaration f pcd = pp f "|@;"; constructor_declaration ctxt f - (pcd.pcd_name.txt, pcd.pcd_args, pcd.pcd_res, pcd.pcd_attributes) + ( pcd.pcd_name.txt, + pcd.pcd_args, + pcd.pcd_res, + Ast_helper.Type.constructor_attributes pcd ) in let repr f = let intro f = if x.ptype_manifest = None then () else pp f "@;=" in diff --git a/compiler/ml/predef.ml b/compiler/ml/predef.ml index 6a2414caab..2de67f84da 100644 --- a/compiler/ml/predef.ml +++ b/compiler/ml/predef.ml @@ -199,6 +199,7 @@ let decl_abstr_imm = {decl_abstr with type_immediate = true} let cstr id args = { cd_id = id; + cd_runtime_tag = None; cd_args = Cstr_tuple args; cd_res = None; cd_loc = Location.none; @@ -345,6 +346,7 @@ let common_initial_env add_type add_extension empty_env = [ { cd_id = ident_ctor_unknown; + cd_runtime_tag = None; cd_args = Cstr_tuple [tvar]; cd_res = Some type_unknown; cd_loc = Location.none; diff --git a/compiler/ml/printast.ml b/compiler/ml/printast.ml index 686ccdcd6c..6b83b1e326 100644 --- a/compiler/ml/printast.ml +++ b/compiler/ml/printast.ml @@ -717,11 +717,10 @@ and core_type_x_core_type_x_location i ppf (ct1, ct2, l) = core_type (i + 1) ppf ct1; core_type (i + 1) ppf ct2 -and constructor_decl i ppf - {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} = +and constructor_decl i ppf ({pcd_name; pcd_args; pcd_res; pcd_loc} as cd) = line i ppf "%a\n" fmt_location pcd_loc; line (i + 1) ppf "%a\n" fmt_string_loc pcd_name; - attributes i ppf pcd_attributes; + attributes i ppf (Ast_helper.Type.constructor_attributes cd); constructor_arguments (i + 1) ppf pcd_args; option (i + 1) core_type ppf pcd_res diff --git a/compiler/ml/subst.ml b/compiler/ml/subst.ml index f7de144a3f..c4d2215d2a 100644 --- a/compiler/ml/subst.ml +++ b/compiler/ml/subst.ml @@ -252,6 +252,7 @@ let constructor_arguments s = function let constructor_declaration s c = { cd_id = c.cd_id; + cd_runtime_tag = c.cd_runtime_tag; cd_args = constructor_arguments s c.cd_args; cd_res = may_map (typexp_rec s) c.cd_res; cd_loc = loc s c.cd_loc; diff --git a/compiler/ml/transl_recmodule.ml b/compiler/ml/transl_recmodule.ml index e22dd39dab..e3ea5b4547 100644 --- a/compiler/ml/transl_recmodule.ml +++ b/compiler/ml/transl_recmodule.ml @@ -25,7 +25,7 @@ let init_shape modl = { name = "Module"; num_nonconst = 2; - runtime = Ast_untagged_variants.block_runtime ~name:"Module" []; + runtime = Ast_untagged_variants.generated_block_runtime ~name:"Module"; } in let value_tag_info : Lambda.tag_info = @@ -33,7 +33,7 @@ let init_shape modl = { name = "value"; num_nonconst = 2; - runtime = Ast_untagged_variants.block_runtime ~name:"value" []; + runtime = Ast_untagged_variants.generated_block_runtime ~name:"value"; } in let rec init_shape_mod env mty = @@ -58,7 +58,7 @@ let init_shape modl = match Ctype.expand_head env ty with | t when is_function t -> const_constructor - (Ast_untagged_variants.constructor_tag ~name:"Function" []) + (Ast_untagged_variants.generated_tag ~name:"Function") | _ -> raise Not_found in add_name init_v id :: init_shape_struct env rem diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index 7f6f5fdc3d..17ac9c44a8 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -487,6 +487,7 @@ let transl_declaration ~type_record_as_object env sdecl id = let constructors_from_variant_spreads = Hashtbl.create 10 in let make_cstr scstr = let name = Ident.create scstr.pcd_name.txt in + let runtime_tag = Ast_untagged_variants.process_constructor_tag scstr in let targs, tret_type, args, ret_type, _cstr_params = make_constructor env (Path.Pident id) params scstr.pcd_args scstr.pcd_res @@ -523,6 +524,7 @@ let transl_declaration ~type_record_as_object env sdecl id = { cd_id = name; cd_name = scstr.pcd_name; + cd_runtime_tag = runtime_tag; cd_args = (match cstr.cd_args with | Cstr_tuple args -> @@ -577,6 +579,7 @@ let transl_declaration ~type_record_as_object env sdecl id = { cd_id = name; cd_name = scstr.pcd_name; + cd_runtime_tag = runtime_tag; cd_args = targs; cd_res = tret_type; cd_loc = scstr.pcd_loc; @@ -587,6 +590,7 @@ let transl_declaration ~type_record_as_object env sdecl id = let cstr = { Types.cd_id = name; + cd_runtime_tag = runtime_tag; cd_args = args; cd_res = ret_type; cd_loc = scstr.pcd_loc; diff --git a/compiler/ml/typedtree.ml b/compiler/ml/typedtree.ml index 2c8f1f4a1f..80793ab465 100644 --- a/compiler/ml/typedtree.ml +++ b/compiler/ml/typedtree.ml @@ -412,6 +412,7 @@ and label_declaration = { and constructor_declaration = { cd_id: Ident.t; cd_name: string loc; + cd_runtime_tag: Variant_runtime.declared_tag option; cd_args: constructor_arguments; cd_res: core_type option; cd_loc: Location.t; diff --git a/compiler/ml/typedtree.mli b/compiler/ml/typedtree.mli index 6dc342c4ac..7965e6a1a9 100644 --- a/compiler/ml/typedtree.mli +++ b/compiler/ml/typedtree.mli @@ -518,6 +518,7 @@ and label_declaration = { and constructor_declaration = { cd_id: Ident.t; cd_name: string loc; + cd_runtime_tag: Variant_runtime.declared_tag option; cd_args: constructor_arguments; cd_res: core_type option; cd_loc: Location.t; diff --git a/compiler/ml/types.ml b/compiler/ml/types.ml index 98d8adc177..11c8062ac8 100644 --- a/compiler/ml/types.ml +++ b/compiler/ml/types.ml @@ -184,6 +184,9 @@ and label_declaration = { and constructor_declaration = { cd_id: Ident.t; + cd_runtime_tag: Variant_runtime.declared_tag option; + (* The decoded [@as] value of the constructor. Its canonical runtime + layout is derived from this field rather than from attributes. *) cd_args: constructor_arguments; cd_res: type_expr option; cd_loc: Location.t; diff --git a/compiler/ml/types.mli b/compiler/ml/types.mli index afd65d485b..c856a7f919 100644 --- a/compiler/ml/types.mli +++ b/compiler/ml/types.mli @@ -281,6 +281,8 @@ and label_declaration = { and constructor_declaration = { cd_id: Ident.t; + cd_runtime_tag: Variant_runtime.declared_tag option; + (* The decoded [@as] value of the constructor. *) cd_args: constructor_arguments; cd_res: type_expr option; cd_loc: Location.t; diff --git a/compiler/ml/variant_layout.ml b/compiler/ml/variant_layout.ml index 9a3ec21fc9..8393b68f7c 100644 --- a/compiler/ml/variant_layout.ml +++ b/compiler/ml/variant_layout.ml @@ -63,7 +63,18 @@ let layout_from_type_variant ~(configuration : configuration) ~env (cstrs : Types.constructor_declaration list) : Variant_runtime.layout = let get_block (cstr : Types.constructor_declaration) : block = { - runtime = block_runtime ~name:(Ident.name cstr.cd_id) cstr.cd_attributes; + runtime = + { + tag = + { + name = Ident.name cstr.cd_id; + tag_type = + Option.map Variant_runtime.tag_type_of_declared + cstr.cd_runtime_tag; + }; + tag_name = process_tag_name cstr.cd_attributes; + untagged = process_untagged cstr.cd_attributes; + }; block_type = get_block_type ~env cstr; } in diff --git a/compiler/ml/variant_runtime.ml b/compiler/ml/variant_runtime.ml index 4730fc3d5c..3c78824c9d 100644 --- a/compiler/ml/variant_runtime.ml +++ b/compiler/ml/variant_runtime.ml @@ -67,6 +67,17 @@ type block_type = | ObjectType | UnknownType +(* A runtime tag written explicitly with [@as]. Unlike [tag_type], this can + never describe an inferred untagged payload shape. *) +type declared_tag = + | Declared_string of string + | Declared_int of int + | Declared_float of string + | Declared_bigint of string + | Declared_bool of bool + | Declared_null + | Declared_undefined + (* Type of the runtime representation of a tag. Can be a literal (case with no payload), or a block (case with payload). @@ -81,6 +92,16 @@ type tag_type = | Null | Undefined (* literal or tagged block *) | Untagged of block_type (* untagged block *) + +let tag_type_of_declared = function + | Declared_string s -> String s + | Declared_int i -> Int i + | Declared_float f -> Float f + | Declared_bigint i -> BigInt i + | Declared_bool b -> Bool b + | Declared_null -> Null + | Declared_undefined -> Undefined + type tag = {name: string; tag_type: tag_type option} type block_runtime = {tag: tag; tag_name: string option; untagged: bool} diff --git a/compiler/ml/variant_runtime.mli b/compiler/ml/variant_runtime.mli index 0158adf830..e680588939 100644 --- a/compiler/ml/variant_runtime.mli +++ b/compiler/ml/variant_runtime.mli @@ -38,6 +38,17 @@ type block_type = | ObjectType | UnknownType +(** A runtime tag written explicitly with [@as]. Unlike [tag_type], this can + never describe an inferred untagged payload shape. *) +type declared_tag = + | Declared_string of string + | Declared_int of int + | Declared_float of string + | Declared_bigint of string + | Declared_bool of bool + | Declared_null + | Declared_undefined + type tag_type = | String of string | Int of int @@ -48,6 +59,8 @@ type tag_type = | Undefined | Untagged of block_type +val tag_type_of_declared : declared_tag -> tag_type + type tag = {name: string; tag_type: tag_type option} type block_runtime = {tag: tag; tag_name: string option; untagged: bool} type block = {runtime: block_runtime; block_type: block_type option} diff --git a/compiler/ml/variant_type_spread.ml b/compiler/ml/variant_type_spread.ml index 4034ddc04a..a1524ac795 100644 --- a/compiler/ml/variant_type_spread.ml +++ b/compiler/ml/variant_type_spread.ml @@ -86,6 +86,15 @@ let map_constructors ~(sdecl : Parsetree.type_declaration) ~all_constructors env pcd_attributes = mk_constructor_comes_from_spread_attr () :: cstr.cd_attributes; + pcd_runtime_tag = + Option.map + (fun txt -> + { + Asttypes.txt = + Ast_untagged_variants.parsetree_tag_of_runtime txt; + loc = cstr.cd_loc; + }) + cstr.cd_runtime_tag; pcd_loc = cstr.cd_loc; pcd_res = None; (* It's important that we _don't_ fill in pcd_args here, since we have no way to produce diff --git a/compiler/syntax/src/res_ast_debugger.ml b/compiler/syntax/src/res_ast_debugger.ml index 1dde1a2566..ff5bc0d26c 100644 --- a/compiler/syntax/src/res_ast_debugger.ml +++ b/compiler/syntax/src/res_ast_debugger.ml @@ -541,7 +541,7 @@ module Sexp_ast = struct | None -> Sexp.atom "None" | Some typ -> Sexp.list [Sexp.atom "Some"; core_type typ]); ]; - attributes cd.pcd_attributes; + attributes (Ast_helper.Type.constructor_attributes cd); ] and constructor_arguments args = diff --git a/compiler/syntax/src/res_printer.ml b/compiler/syntax/src/res_printer.ml index f9f3ecdb20..64b41811f5 100644 --- a/compiler/syntax/src/res_printer.ml +++ b/compiler/syntax/src/res_printer.ml @@ -1768,8 +1768,9 @@ and print_constructor_declarations ~state ~private_flag and print_constructor_declaration2 ~state i (cd : Parsetree.constructor_declaration) cmt_tbl = + let all_attrs = Ast_helper.Type.constructor_attributes cd in let comment_attrs, attrs = - Parsetree_viewer.partition_doc_comment_attributes cd.pcd_attributes + Parsetree_viewer.partition_doc_comment_attributes all_attrs in let comment_doc = match comment_attrs with @@ -1780,7 +1781,7 @@ and print_constructor_declaration2 ~state i let attrs = print_attributes ~state attrs cmt_tbl in let is_dot_dot_dot = cd.pcd_name.txt = "..." in let bar = - if i > 0 || cd.pcd_attributes <> [] || is_dot_dot_dot then Doc.text "| " + if i > 0 || all_attrs <> [] || is_dot_dot_dot then Doc.text "| " else Doc.if_breaks (Doc.text "| ") Doc.nil in let constr_name = diff --git a/tests/ERROR_VARIANTS.md b/tests/ERROR_VARIANTS.md index 989f9b1207..0bab798c83 100644 --- a/tests/ERROR_VARIANTS.md +++ b/tests/ERROR_VARIANTS.md @@ -457,6 +457,7 @@ Untagged-variant validation errors. Source: [ast_untagged_variants.ml:52](../com | Variant | Status | Fixture | Notes | |---|---|---|---| | `InvalidVariantAsAnnotation` | ✓ | `UntaggedInvalidVariantAsAnnotation.res` | `@as(foo)` with a non-`null` / non-`undefined` identifier payload. | +| `VariantAsIntegerOutOfRange` | ✓ | `VariantAsIntegerOutOfRange.res` | Integer literal in a constructor `@as` annotation exceeds the compiler's integer range. | | `Duplicated_bs_as` | ✓ | `UntaggedDuplicatedBsAs.res` | Two `@as("...")` attributes on the same constructor. | | `InvalidVariantTagAnnotation` | ✓ | `UntaggedInvalidVariantTagAnnotation.res` | `@tag(123)` (non-string payload). | | `InvalidUntaggedVariantDefinition` | ✓ | `UntaggedUnknown.res`, `UntaggedNonUnary*.res`, `UntaggedTupleAndArray.res`, `UntaggedImplIntf.res`, etc. | | diff --git a/tests/analysis_tests/tests/src/CompletionAttributes.res b/tests/analysis_tests/tests/src/CompletionAttributes.res index 31d13b6508..527cb64378 100644 --- a/tests/analysis_tests/tests/src/CompletionAttributes.res +++ b/tests/analysis_tests/tests/src/CompletionAttributes.res @@ -39,3 +39,6 @@ // type withAs = {@as("wire") a: int} // ^com + +// type withTag = | @as("t") A | B +// ^com diff --git a/tests/analysis_tests/tests/src/expected/CompletionAttributes.res.txt b/tests/analysis_tests/tests/src/expected/CompletionAttributes.res.txt index bd93a11e81..b4e8c6146c 100644 --- a/tests/analysis_tests/tests/src/expected/CompletionAttributes.res.txt +++ b/tests/analysis_tests/tests/src/expected/CompletionAttributes.res.txt @@ -295,3 +295,23 @@ Resolved opens 1 Stdlib } ] +Complete src/CompletionAttributes.res 42:23 +Attribute id:as:[42:20->42:23] label:as +Completable: Cdecorator(as) +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +[ + { + "detail": "", + "documentation": { + "kind": "markdown", + "value": "The `@as` decorator is commonly used on record types to alias record field names to a different JavaScript attribute name.\n\nThis is useful to map to JavaScript attribute names that cannot be expressed in ReScript (such as keywords).\n\nIt is also possible to map a ReScript record to a JavaScript array by passing indices to the `@as` decorator.\n\n[Read more and see examples in the documentation](https://rescript-lang.org/syntax-lookup#as-decorator)." + }, + "insertText": "as(\"$0\")", + "insertTextFormat": 2, + "kind": 4, + "label": "as", + "tags": [] + } +] + diff --git a/tests/build_tests/super_errors/expected/VariantAsIntegerOutOfRange.res.expected b/tests/build_tests/super_errors/expected/VariantAsIntegerOutOfRange.res.expected new file mode 100644 index 0000000000..8bff185554 --- /dev/null +++ b/tests/build_tests/super_errors/expected/VariantAsIntegerOutOfRange.res.expected @@ -0,0 +1,8 @@ + + We've found a bug for you! + /.../fixtures/VariantAsIntegerOutOfRange.res:1:12-14 + + 1 │ type t = | @as(999999999999999999999999999999999999) TooLarge | Other + 2 │ + + The integer 999999999999999999999999999999999999 in this variant case's @as annotation is out of range. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/VariantAsIntegerOutOfRange.res b/tests/build_tests/super_errors/fixtures/VariantAsIntegerOutOfRange.res new file mode 100644 index 0000000000..84f118e5da --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/VariantAsIntegerOutOfRange.res @@ -0,0 +1 @@ +type t = | @as(999999999999999999999999999999999999) TooLarge | Other diff --git a/tests/ounit_tests/ounit_ast_mapper0_tests.ml b/tests/ounit_tests/ounit_ast_mapper0_tests.ml index 77dbd7ae96..21b215875e 100644 --- a/tests/ounit_tests/ounit_ast_mapper0_tests.ml +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -160,6 +160,27 @@ let test_field_runtime_name_keeps_its_place_on_the_wire _ = (fun (({txt} : string Asttypes.loc), _) -> txt) field0.pld_attributes) +let test_constructor_runtime_tag_reaches_ast0_as_an_attribute _ = + let as_attr = + attr "as" + (Parsetree.PStr + [ + Ast_helper.Str.eval + (Ast_helper.Exp.constant (Pconst_integer ("7", None))); + ]) + in + let constructor = + Ast_helper.Type.constructor ~loc ~attrs:[as_attr] (located_string "Seven") + in + OUnit.assert_bool "Expected the @as attribute to become the runtime tag" + (constructor.pcd_runtime_tag <> None); + let constructor0 = + Ast_mapper_to0.default_mapper.constructor_declaration + Ast_mapper_to0.default_mapper constructor + in + OUnit.assert_bool "Expected a plain @as attribute on the ast0 wire" + (has_attr "as" constructor0.pcd_attributes) + let map_expr0 e = Ast_mapper_from0.default_mapper.expr Ast_mapper_from0.default_mapper e @@ -799,4 +820,6 @@ let suites = >:: test_field_runtime_name_keeps_its_place_on_the_wire; "field_runtime_name_keeps_ppx_order_on_the_wire" >:: test_field_runtime_name_keeps_ppx_order_on_the_wire; + "constructor_runtime_tag_reaches_ast0_as_an_attribute" + >:: test_constructor_runtime_tag_reaches_ast0_as_an_attribute; ] diff --git a/tests/syntax_tests/data/ast-mapping/VariantConstructorTags.res b/tests/syntax_tests/data/ast-mapping/VariantConstructorTags.res new file mode 100644 index 0000000000..fce0224061 --- /dev/null +++ b/tests/syntax_tests/data/ast-mapping/VariantConstructorTags.res @@ -0,0 +1,26 @@ +type renamed = + | @as("b") A + | B + +@unboxed type escaped = | @as("a\nb\"c") Escaped + +/* Keep the source spelling in the parsetree rather than reconstructing it + from the decoded runtime string. */ +@unboxed type nonCanonical = | @as("\u0041") NonCanonical + +@unboxed type backquoted = | @as(`tick`) Backquoted + +type otherLiterals = + | @as(1) Int + | @as(0xA) Hex + | @as(1.5) Float + | @as(1n) BigInt + | @as(true) Bool + | @as(null) Null + | @as(undefined) Undefined + +@unboxed type notATag = | @as(Array) Invalid + +@unboxed type twoTags = | @as("one") @as("two") Two + +@unboxed type ordered = | @dead("x") @as("two") Ordered diff --git a/tests/syntax_tests/data/ast-mapping/expected/VariantConstructorTags.res.txt b/tests/syntax_tests/data/ast-mapping/expected/VariantConstructorTags.res.txt new file mode 100644 index 0000000000..ce93707ab1 --- /dev/null +++ b/tests/syntax_tests/data/ast-mapping/expected/VariantConstructorTags.res.txt @@ -0,0 +1,26 @@ +type renamed = + | @as("b") A + | B + +@unboxed type escaped = | @as("a\nb\"c") Escaped + +/* Keep the source spelling in the parsetree rather than reconstructing it + from the decoded runtime string. */ +@unboxed type nonCanonical = | @as("\u0041") NonCanonical + +@unboxed type backquoted = | @as("tick") Backquoted + +type otherLiterals = + | @as(1) Int + | @as(0xA) Hex + | @as(1.5) Float + | @as(1n) BigInt + | @as(true) Bool + | @as(null) Null + | @as(undefined) Undefined + +@unboxed type notATag = | @as(Array) Invalid + +@unboxed type twoTags = | @as("one") @as("two") Two + +@unboxed type ordered = | @dead("x") @as("two") Ordered diff --git a/tests/tests/src/variant_constructor_as_spelling_test.mjs b/tests/tests/src/variant_constructor_as_spelling_test.mjs new file mode 100644 index 0000000000..12659b0d25 --- /dev/null +++ b/tests/tests/src/variant_constructor_as_spelling_test.mjs @@ -0,0 +1,11 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + + +let Renamed = { + value: "A" +}; + +export { + Renamed, +} +/* No side effect */ diff --git a/tests/tests/src/variant_constructor_as_spelling_test.res b/tests/tests/src/variant_constructor_as_spelling_test.res new file mode 100644 index 0000000000..2376f40a26 --- /dev/null +++ b/tests/tests/src/variant_constructor_as_spelling_test.res @@ -0,0 +1,11 @@ +/* A constructor's runtime tag is its decoded value, not the source spelling. + The signature and implementation therefore describe the same variant. */ +module Renamed: { + @unboxed type t = | @as("\u0041") Renamed + + let value: t +} = { + @unboxed type t = | @as("A") Renamed + + let value = Renamed +} From 141d796653e4c7b0da2275627a1d27d999e0263e Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Thu, 3 Sep 2026 17:23:09 +0200 Subject: [PATCH 05/10] Give a variant tag one decoded representation The seven cases a constructor's @as can state existed twice: once as declared_tag, and again as seven of tag_type's eight constructors, joined by a conversion. Nothing ever matched on declared_tag for a decision; every use mapped it straight to tag_type. So tag_type now holds the narrower type rather than repeating it, and the conversion becomes the constructor: type tag_type = Literal of literal_tag | Untagged of block_type Renamed from declared_tag, because two sites build the literal for a constructor that declares nothing -- the default encoding is the constructor's own name -- and because the surrounding code already calls these literals: literal_tags, literal_cases, is_a_literal_case, check_literal. Functions that only ever handled literals now say so in their type: js_exp_make's tag_type splits into the JS value a literal stands for and the typeof string an untagged payload answers to, which were unrelated jobs sharing one match, and printtyp's @as reconstruction takes a literal_tag. Where a match arm per literal remains it unwraps Literal once instead of in every arm, and variant_coercion's four arms that differed only in the expected type become a table. Signed-off-by: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/js_exp_make.ml | 28 ++++--- compiler/core/js_of_lam_variant.ml | 6 +- compiler/core/js_stmt_make.ml | 6 +- compiler/core/lam_compile.ml | 8 +- .../gentype/translate_type_declarations.ml | 19 +++-- compiler/ml/ast_untagged_variants.ml | 83 ++++++++++--------- compiler/ml/error_message_utils.ml | 2 +- compiler/ml/lambda.ml | 17 ++-- compiler/ml/printtyp.ml | 17 ++-- compiler/ml/typedtree.ml | 2 +- compiler/ml/typedtree.mli | 2 +- compiler/ml/typeopt.ml | 2 +- compiler/ml/types.ml | 2 +- compiler/ml/types.mli | 2 +- compiler/ml/variant_coercion.ml | 68 ++++++--------- compiler/ml/variant_layout.ml | 3 +- compiler/ml/variant_runtime.ml | 47 ++++------- compiler/ml/variant_runtime.mli | 19 ++--- 18 files changed, 157 insertions(+), 176 deletions(-) diff --git a/compiler/core/js_exp_make.ml b/compiler/core/js_exp_make.ml index 32f46c2e39..a1df38f00d 100644 --- a/compiler/core/js_exp_make.ml +++ b/compiler/core/js_exp_make.ml @@ -1389,7 +1389,8 @@ let rec float_equal ?comment (e0 : t) (e1 : t) : t = let int_equal = float_equal -let tag_type = function +(* The JS value a declared tag stands for. *) +let literal_tag = function | Variant_runtime.String s -> str s | Int i -> small_int i | Float f -> float f @@ -1399,19 +1400,24 @@ let tag_type = function | Bool b -> bool b | Null -> nil | Undefined -> undefined - | Untagged IntType -> str "number" - | Untagged FloatType -> str "number" - | Untagged BigintType -> str "bigint" - | Untagged BooleanType -> str "boolean" - | Untagged FunctionType -> str "function" - | Untagged StringType -> str "string" - | Untagged (InstanceType i) -> - js_global (Variant_runtime.Instance.to_string i) - | Untagged ObjectType -> str "object" - | Untagged UnknownType -> + +(* The [typeof] string an untagged payload answers to. *) +let block_type_name = function + | Variant_runtime.IntType | FloatType -> str "number" + | BigintType -> str "bigint" + | BooleanType -> str "boolean" + | FunctionType -> str "function" + | StringType -> str "string" + | InstanceType i -> js_global (Variant_runtime.Instance.to_string i) + | ObjectType -> str "object" + | UnknownType -> (* TODO: this should not happen *) assert false +let tag_type = function + | Variant_runtime.Literal d -> literal_tag d + | Untagged b -> block_type_name b + let rec emit_check (check : t Ast_untagged_variants.Dynamic_checks.t) = match check with | TagType t -> tag_type t diff --git a/compiler/core/js_of_lam_variant.ml b/compiler/core/js_of_lam_variant.ml index a027587122..5d6c27c1f1 100644 --- a/compiler/core/js_of_lam_variant.ml +++ b/compiler/core/js_of_lam_variant.ml @@ -40,7 +40,7 @@ let eval (arg : J.expression) (dispatches : (string * string) list) : E.t = [ S.string_switch arg (Ext_list.map dispatches (fun (s, r) -> - ( Variant_runtime.String s, + ( Variant_runtime.Literal (String s), J. { switch_body = [S.return_stmt (E.str r)]; @@ -81,7 +81,7 @@ let eval_as_event (arg : J.expression) S.string_switch (E.poly_var_tag_access arg) (Ext_list.map dispatches (fun (s, r) -> - ( Variant_runtime.String s, + ( Variant_runtime.Literal (String s), J. { switch_body = [S.return_stmt (E.str r)]; @@ -110,7 +110,7 @@ let eval_as_int (arg : J.expression) (dispatches : (string * int) list) : E.t = [ S.string_switch arg (Ext_list.map dispatches (fun (s, r) -> - ( Variant_runtime.String s, + ( Variant_runtime.Literal (String s), J. { switch_body = [S.return_stmt (E.int (Int32.of_int r))]; diff --git a/compiler/core/js_stmt_make.ml b/compiler/core/js_stmt_make.ml index 14937b04fd..214c9c2069 100644 --- a/compiler/core/js_stmt_make.ml +++ b/compiler/core/js_stmt_make.ml @@ -149,10 +149,8 @@ let string_switch ?(comment : string option) match Ext_list.find_opt clauses (fun (switch_case, x) -> match switch_case with - | String s -> if s = txt then Some x.switch_body else None - | Int _ | Float _ | BigInt _ | Bool _ | Null | Undefined - | Untagged _ -> - None) + | Literal (String s) -> if s = txt then Some x.switch_body else None + | Literal _ | Untagged _ -> None) with | Some case -> case | None -> ( diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index 5910f49291..8d1f4c46ec 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -700,7 +700,7 @@ let compile output_prefix = | Some {Variant_runtime.tag_type = Some t}, Some string_table -> Some ((t, lam) :: string_table) | Some {name; tag_type = None}, Some string_table -> - Some ((String name, lam) :: string_table) + Some ((Literal (String name), lam) :: string_table) | _, _ -> None) table (Some []) and compile_cases ?(untagged = false) ?(has_null_case = false) ~cxt @@ -793,7 +793,9 @@ let compile output_prefix = && List.length sw_consts = 0 && eq_default sw_num_default sw_blocks_default then - let has_null_case = List.mem Variant_runtime.Null literal_cases in + let has_null_case = + List.mem (Variant_runtime.Literal Null) literal_cases + in compile_cases ~untagged ~cxt ~switch_exp:(if untagged then e else E.tag ~name:tag_name e) ~block_cases ~has_null_case ~default:sw_blocks_default sw_blocks @@ -935,7 +937,7 @@ let compile output_prefix = The [gen] can be elimiated when number of [cases] is less than 3 *) let cases = - cases |> List.map (fun (s, l) -> (Variant_runtime.String s, l)) + cases |> List.map (fun (s, l) -> (Variant_runtime.Literal (String s), l)) in match compile_lambda {lambda_cxt with continuation = NeedValue Not_tail} l diff --git a/compiler/gentype/translate_type_declarations.ml b/compiler/gentype/translate_type_declarations.ml index ccd0869cc5..6ad4475935 100644 --- a/compiler/gentype/translate_type_declarations.ml +++ b/compiler/gentype/translate_type_declarations.ml @@ -41,15 +41,16 @@ let create_polyvariant_case (label, attributes) = } let create_variant_case label = function - | Some (Variant_runtime.String label) -> - {label_js = StringLabel (Emit_text.escape_string_contents label)} - | Some (Variant_runtime.Int label) -> - {label_js = IntLabel (string_of_int label)} - | Some (Variant_runtime.Float label) -> {label_js = FloatLabel label} - | Some (Variant_runtime.BigInt label) -> {label_js = IntLabel label} - | Some (Variant_runtime.Bool label) -> {label_js = BoolLabel label} - | Some Variant_runtime.Null -> {label_js = NullLabel} - | Some Variant_runtime.Undefined -> {label_js = UndefinedLabel} + | Some (Variant_runtime.Literal declared) -> ( + match declared with + | String label -> + {label_js = StringLabel (Emit_text.escape_string_contents label)} + | Int label -> {label_js = IntLabel (string_of_int label)} + | Float label -> {label_js = FloatLabel label} + | BigInt label -> {label_js = IntLabel label} + | Bool label -> {label_js = BoolLabel label} + | Null -> {label_js = NullLabel} + | Undefined -> {label_js = UndefinedLabel}) | Some (Variant_runtime.Untagged _) | None -> {label_js = StringLabel label} (** diff --git a/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml index 582c54d234..2fe4c8d450 100644 --- a/compiler/ml/ast_untagged_variants.ml +++ b/compiler/ml/ast_untagged_variants.ml @@ -79,7 +79,7 @@ let block_type_to_user_visible_string = function Can be a literal (case with no payload), or a block (case with payload). In the case of block it can be tagged or untagged. *) -let tag_type_to_user_visible_string = function +let declared_tag_to_user_visible_string = function | String _ -> "string" | Int _ -> "int" | Float _ -> "float" @@ -87,6 +87,9 @@ let tag_type_to_user_visible_string = function | Bool _ -> "bool" | Null -> "null" | Undefined -> "undefined" + +let tag_type_to_user_visible_string = function + | Literal d -> declared_tag_to_user_visible_string d | Untagged block_type -> block_type_to_user_visible_string block_type let untagged = "unboxed" @@ -100,9 +103,9 @@ let block_type_can_be_undefined = function let tag_can_be_undefined tag = match tag.tag_type with | None -> false - | Some (String _ | Int _ | Float _ | BigInt _ | Bool _ | Null) -> false + | Some (Literal Undefined) -> true + | Some (Literal _) -> false | Some (Untagged block_type) -> block_type_can_be_undefined block_type - | Some Undefined -> true let has_untagged (attrs : Parsetree.attributes) = Ext_list.exists attrs (function {txt}, _ -> txt = untagged) @@ -116,26 +119,25 @@ let process_untagged (attrs : Parsetree.attributes) = !st let runtime_tag_of_parsetree ~loc = function - | Parsetree.Pct_string s -> Declared_string (String_literal.string_semantic s) + | Parsetree.Pct_string s -> String (String_literal.string_semantic s) | Pct_int source -> ( match int_of_string_opt source with - | Some i -> Declared_int i + | Some i -> Int i | None -> raise (Error (loc, VariantAsIntegerOutOfRange source))) - | Pct_float f -> Declared_float f - | Pct_bigint i -> Declared_bigint i - | Pct_bool b -> Declared_bool b - | Pct_null -> Declared_null - | Pct_undefined -> Declared_undefined + | Pct_float f -> Float f + | Pct_bigint i -> BigInt i + | Pct_bool b -> Bool b + | Pct_null -> Null + | Pct_undefined -> Undefined let parsetree_tag_of_runtime = function - | Declared_string s -> - Parsetree.Pct_string (String_literal.string_from_semantic s) - | Declared_int i -> Pct_int (string_of_int i) - | Declared_float f -> Pct_float f - | Declared_bigint i -> Pct_bigint i - | Declared_bool b -> Pct_bool b - | Declared_null -> Pct_null - | Declared_undefined -> Pct_undefined + | String s -> Parsetree.Pct_string (String_literal.string_from_semantic s) + | Int i -> Pct_int (string_of_int i) + | Float f -> Pct_float f + | BigInt i -> Pct_bigint i + | Bool b -> Pct_bool b + | Null -> Pct_null + | Undefined -> Pct_undefined (* An [@as] left in the attributes did not name the constructor: either its payload is not a tag, or an earlier [@as] already named it. *) @@ -292,16 +294,18 @@ let check_invariant ~is_untagged_def ~(consts : (Location.t * tag) list) in let check_literal ~is_const ~loc (literal : tag) = match literal.tag_type with - | Some (String s) -> add_string_literal ~is_const ~loc s - | Some (Int i) -> add_nonstring_literal ~is_const ~loc (string_of_int i) - | Some (Float f) -> add_nonstring_literal ~is_const ~loc f - | Some (BigInt i) -> add_nonstring_literal ~is_const ~loc i - | Some Null -> add_nonstring_literal ~is_const ~loc "null" - | Some Undefined -> add_nonstring_literal ~is_const ~loc "undefined" - | Some (Bool b) -> - add_nonstring_literal ~is_const ~loc (if b then "true" else "false") - | Some (Untagged _) -> () | None -> add_string_literal ~is_const ~loc literal.name + | Some (Untagged _) -> () + | Some (Literal d) -> ( + match d with + | String s -> add_string_literal ~is_const ~loc s + | Int i -> add_nonstring_literal ~is_const ~loc (string_of_int i) + | Float f -> add_nonstring_literal ~is_const ~loc f + | BigInt i -> add_nonstring_literal ~is_const ~loc i + | Bool b -> + add_nonstring_literal ~is_const ~loc (if b then "true" else "false") + | Null -> add_nonstring_literal ~is_const ~loc "null" + | Undefined -> add_nonstring_literal ~is_const ~loc "undefined") in Ext_list.rev_iter consts (fun (loc, literal) -> @@ -333,7 +337,7 @@ let get_cstr_loc_tag (cstr : Types.constructor_declaration) = ( cstr.cd_loc, { name = Ident.name cstr.cd_id; - tag_type = Option.map tag_type_of_declared cstr.cd_runtime_tag; + tag_type = Option.map (fun d -> Literal d) cstr.cd_runtime_tag; } ) let check_tag_field_conflicts (cstrs : Types.constructor_declaration list) = @@ -383,11 +387,11 @@ module Dynamic_checks = struct let bin op x y = BinOp (op, x, y) let tag_type t = TagType t let typeof x = TypeOf x - let str s = String s |> tag_type + let str s = Literal (String s) |> tag_type let is_instance i x = IsInstanceOf (i, x) let not x = Not x - let nil = Null |> tag_type - let undefined = Undefined |> tag_type + let nil = Literal Null |> tag_type + let undefined = Literal Undefined |> tag_type let object_ = Untagged ObjectType |> tag_type let function_ = Untagged FunctionType |> tag_type @@ -405,28 +409,33 @@ module Dynamic_checks = struct let rec is_a_literal_case ~(literal_cases : tag_type list) ~block_cases ~list_literal_cases (e : _ t) = - let literals_overlaps_with_string () = + let overlaps p = Ext_list.exists literal_cases (function + | Literal d -> p d + | Untagged _ -> false) + in + let literals_overlaps_with_string () = + overlaps (function | String _ -> true | _ -> false) in let literals_overlaps_with_number () = - Ext_list.exists literal_cases (function + overlaps (function | Int _ | Float _ -> true | _ -> false) in let literals_overlaps_with_bigint () = - Ext_list.exists literal_cases (function + overlaps (function | BigInt _ -> true | _ -> false) in let literals_overlaps_with_boolean () = - Ext_list.exists literal_cases (function + overlaps (function | Bool _ -> true | _ -> false) in let literals_overlaps_with_object () = - Ext_list.exists literal_cases (function + overlaps (function | Null -> true | _ -> false) in @@ -539,5 +548,5 @@ module Dynamic_checks = struct | Untagged UnknownType -> (* This should not happen because unknown must be the only non-literal case *) assert false - | Bool _ | Float _ | Int _ | BigInt _ | String _ | Null | Undefined -> x + | Literal _ -> x end diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index 4ee3f1aeaf..7ec18b9519 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -708,7 +708,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf let constructor_name = Ident.name cd.cd_id in let runtime_repr = match Variant_runtime.constructor_tag layout position with - | Some (String s) -> Some s (* @as("string_value") *) + | Some (Literal (String s)) -> Some s (* @as("string_value") *) | Some _ -> None (* @as with non-string values *) | None -> Some constructor_name (* No @as, use constructor name *) in diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 7c961e3ad0..8c7c32c898 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -419,7 +419,7 @@ let const_constructor (tag : Variant_runtime.tag) = if tag.name = "()" then const_unit else match tag.tag_type with - | Some (Variant_runtime.Int v) -> Const_int (Int32.of_int v) + | Some (Variant_runtime.Literal (Int v)) -> Const_int (Int32.of_int v) | _ -> Const_constructor tag (* A constructor with an optional shape carries no payload when constant. *) @@ -800,7 +800,7 @@ let switch lam (lam_switch : lambda_switch) : t = match key with | Switch_int ordinal when ordinal = i -> Some action | Switch_constructor - (Constant {tag_type = Some (Variant_runtime.Int value)}) + (Constant {tag_type = Some (Variant_runtime.Literal (Int value))}) when value = i -> Some action | Switch_int _ | Switch_constructor _ -> None) @@ -1045,11 +1045,14 @@ let rec eval_const_as_bool (v : structured_constant) : bool option = (* Truthiness of the canonical runtime representation *) match tag_type with | None -> Some (name <> "[]") (* the name string; [] is the number 0 *) - | Some (String s) -> Some (s <> "") - | Some (Int i) -> Some (i <> 0) - | Some (Bool b) -> Some b - | Some Null | Some Undefined -> Some false - | Some (Float _ | BigInt _ | Untagged _) -> None) + | Some (Untagged _) -> None + | Some (Literal d) -> ( + match d with + | String s -> Some (s <> "") + | Int i -> Some (i <> 0) + | Bool b -> Some b + | Null | Undefined -> Some false + | Float _ | BigInt _ -> None)) let if_ (a : t) (b : t) (c : t) : t = match a with diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index b878e6f7ed..a39bcf80db 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -881,14 +881,17 @@ and tree_of_constructor ?printing_context ~layout ~position cd = let repr = if not nullary then None else + let as_annotation = function + | Variant_runtime.Null -> "@as(null)" + | Undefined -> "@as(undefined)" + | String s -> Printf.sprintf "@as(%S)" s + | Int i -> Printf.sprintf "@as(%d)" i + | Float f -> Printf.sprintf "@as(%s)" f + | Bool b -> Printf.sprintf "@as(%b)" b + | BigInt s -> Printf.sprintf "@as(%sn)" s + in match Variant_runtime.constructor_tag layout position with - | Some Null -> Some "@as(null)" - | Some Undefined -> Some "@as(undefined)" - | Some (String s) -> Some (Printf.sprintf "@as(%S)" s) - | Some (Int i) -> Some (Printf.sprintf "@as(%d)" i) - | Some (Float f) -> Some (Printf.sprintf "@as(%s)" f) - | Some (Bool b) -> Some (Printf.sprintf "@as(%b)" b) - | Some (BigInt s) -> Some (Printf.sprintf "@as(%sn)" s) + | Some (Literal d) -> Some (as_annotation d) | Some (Untagged _) (* should never happen *) | None -> None in let arg () = tree_of_constructor_arguments ?printing_context cd.cd_args in diff --git a/compiler/ml/typedtree.ml b/compiler/ml/typedtree.ml index 80793ab465..ff1802caca 100644 --- a/compiler/ml/typedtree.ml +++ b/compiler/ml/typedtree.ml @@ -412,7 +412,7 @@ and label_declaration = { and constructor_declaration = { cd_id: Ident.t; cd_name: string loc; - cd_runtime_tag: Variant_runtime.declared_tag option; + cd_runtime_tag: Variant_runtime.literal_tag option; cd_args: constructor_arguments; cd_res: core_type option; cd_loc: Location.t; diff --git a/compiler/ml/typedtree.mli b/compiler/ml/typedtree.mli index 7965e6a1a9..618e893faf 100644 --- a/compiler/ml/typedtree.mli +++ b/compiler/ml/typedtree.mli @@ -518,7 +518,7 @@ and label_declaration = { and constructor_declaration = { cd_id: Ident.t; cd_name: string loc; - cd_runtime_tag: Variant_runtime.declared_tag option; + cd_runtime_tag: Variant_runtime.literal_tag option; cd_args: constructor_arguments; cd_res: core_type option; cd_loc: Location.t; diff --git a/compiler/ml/typeopt.ml b/compiler/ml/typeopt.ml index 66a1e8c32d..8a8e215cbe 100644 --- a/compiler/ml/typeopt.ml +++ b/compiler/ml/typeopt.ml @@ -79,7 +79,7 @@ let rec type_cannot_contain_undefined (typ : Types.type_expr) (env : Env.t) = | Variant_runtime.Block {runtime = {tag; untagged}} -> (tag, untagged) in - tag.tag_type <> Some Variant_runtime.Undefined + tag.tag_type <> Some (Variant_runtime.Literal Undefined) && ((not payload_is_unboxed) || match cd.cd_args with diff --git a/compiler/ml/types.ml b/compiler/ml/types.ml index 11c8062ac8..94147e9034 100644 --- a/compiler/ml/types.ml +++ b/compiler/ml/types.ml @@ -184,7 +184,7 @@ and label_declaration = { and constructor_declaration = { cd_id: Ident.t; - cd_runtime_tag: Variant_runtime.declared_tag option; + cd_runtime_tag: Variant_runtime.literal_tag option; (* The decoded [@as] value of the constructor. Its canonical runtime layout is derived from this field rather than from attributes. *) cd_args: constructor_arguments; diff --git a/compiler/ml/types.mli b/compiler/ml/types.mli index c856a7f919..47c2aaf147 100644 --- a/compiler/ml/types.mli +++ b/compiler/ml/types.mli @@ -281,7 +281,7 @@ and label_declaration = { and constructor_declaration = { cd_id: Ident.t; - cd_runtime_tag: Variant_runtime.declared_tag option; + cd_runtime_tag: Variant_runtime.literal_tag option; (* The decoded [@as] value of the constructor. *) cd_args: constructor_arguments; cd_res: type_expr option; diff --git a/compiler/ml/variant_coercion.ml b/compiler/ml/variant_coercion.ml index 2aa704500a..fb5ec466ef 100644 --- a/compiler/ml/variant_coercion.ml +++ b/compiler/ml/variant_coercion.ml @@ -72,48 +72,30 @@ let variant_has_same_runtime_representation_as_target ~(target_path : Path.t) | Cstr_tuple [] -> ( (* Check that @as payloads match with the target path to coerce to. No @as means the default encoding, which is string *) - match as_payload with - | None | Some (String _) -> - if Path.same target_path Predef.path_string then None - else - Some - (Mismatched_as_payload - { - constructor_name = Ident.name c.cd_id; - expected_typename = target_path; - as_payload; - }) - | Some (Int _) -> - if Path.same target_path Predef.path_int then None - else - Some - (Mismatched_as_payload - { - constructor_name = Ident.name c.cd_id; - expected_typename = target_path; - as_payload; - }) - | Some (Float _) -> - if Path.same target_path Predef.path_float then None - else - Some - (Mismatched_as_payload - { - constructor_name = Ident.name c.cd_id; - expected_typename = target_path; - as_payload; - }) - | Some (BigInt _) -> - if Path.same target_path Predef.path_bigint then None - else - Some - (Mismatched_as_payload - { - constructor_name = Ident.name c.cd_id; - expected_typename = target_path; - as_payload; - }) - | Some ((Null | Undefined | Bool _ | Untagged _) as as_payload) -> + (* Each literal kind coerces to exactly one predefined type; the kinds + with no such type cannot be coerced at all. *) + let coercion = + match as_payload with + | None -> `Coerces_to Predef.path_string + | Some (Literal (String _)) -> `Coerces_to Predef.path_string + | Some (Literal (Int _)) -> `Coerces_to Predef.path_int + | Some (Literal (Float _)) -> `Coerces_to Predef.path_float + | Some (Literal (BigInt _)) -> `Coerces_to Predef.path_bigint + | Some ((Literal (Null | Undefined | Bool _) | Untagged _) as payload) + -> + `Not_eligible payload + in + match coercion with + | `Coerces_to path when Path.same target_path path -> None + | `Coerces_to _ -> + Some + (Mismatched_as_payload + { + constructor_name = Ident.name c.cd_id; + expected_typename = target_path; + as_payload; + }) + | `Not_eligible as_payload -> Some (As_payload_not_elgible_for_coercion { @@ -272,7 +254,7 @@ let can_coerce_polyvariant_to_variant ~row_fields ~variant_constructors ~layout |> List.mapi (fun position (c : Types.constructor_declaration) -> let constructor_name = Ident.name c.cd_id in match Variant_runtime.constructor_tag layout position with - | Some (String as_runtime_string) -> + | Some (Literal (String as_runtime_string)) -> (* `@as("")`, does the configured string match the polyvariant value? *) as_runtime_string = polyvariant_value | Some _ -> diff --git a/compiler/ml/variant_layout.ml b/compiler/ml/variant_layout.ml index 8393b68f7c..f67e8342d3 100644 --- a/compiler/ml/variant_layout.ml +++ b/compiler/ml/variant_layout.ml @@ -69,7 +69,8 @@ let layout_from_type_variant ~(configuration : configuration) ~env { name = Ident.name cstr.cd_id; tag_type = - Option.map Variant_runtime.tag_type_of_declared + Option.map + (fun d -> Variant_runtime.Literal d) cstr.cd_runtime_tag; }; tag_name = process_tag_name cstr.cd_attributes; diff --git a/compiler/ml/variant_runtime.ml b/compiler/ml/variant_runtime.ml index 3c78824c9d..cfab52a001 100644 --- a/compiler/ml/variant_runtime.ml +++ b/compiler/ml/variant_runtime.ml @@ -67,16 +67,17 @@ type block_type = | ObjectType | UnknownType -(* A runtime tag written explicitly with [@as]. Unlike [tag_type], this can - never describe an inferred untagged payload shape. *) -type declared_tag = - | Declared_string of string - | Declared_int of int - | Declared_float of string - | Declared_bigint of string - | Declared_bool of bool - | Declared_null - | Declared_undefined +(* The literal value a constructor is represented by: what [@as] states, or + the constructor's own name when it states nothing. Unlike [tag_type], this + can never describe an inferred untagged payload shape. *) +type literal_tag = + | String of string + | Int of int + | Float of string + | BigInt of string + | Bool of bool + | Null + | Undefined (* Type of the runtime representation of a tag. @@ -84,24 +85,9 @@ type declared_tag = In the case of block it can be tagged or untagged. *) type tag_type = - | String of string - | Int of int - | Float of string - | BigInt of string - | Bool of bool - | Null - | Undefined (* literal or tagged block *) + | Literal of literal_tag (* literal or tagged block *) | Untagged of block_type (* untagged block *) -let tag_type_of_declared = function - | Declared_string s -> String s - | Declared_int i -> Int i - | Declared_float f -> Float f - | Declared_bigint i -> BigInt i - | Declared_bool b -> Bool b - | Declared_null -> Null - | Declared_undefined -> Undefined - type tag = {name: string; tag_type: tag_type option} type block_runtime = {tag: tag; tag_name: string option; untagged: bool} @@ -207,14 +193,13 @@ let compute_matching_facts ~tag_name (constructors : constructor_case array) : let tag = match tag_type with | Some tag -> tag - | None -> String name + | None -> Literal (String name) in literal_tags := tag :: !literal_tags; match tag with - | Null -> has_null := true - | Undefined -> has_undefined := true - | String _ | Int _ | Float _ | BigInt _ | Bool _ | Untagged _ -> - has_other_literal := true) + | Literal Null -> has_null := true + | Literal Undefined -> has_undefined := true + | Literal _ | Untagged _ -> has_other_literal := true) | Block {block_type} -> ( match block_type with | Some block_type -> block_types := block_type :: !block_types diff --git a/compiler/ml/variant_runtime.mli b/compiler/ml/variant_runtime.mli index e680588939..e6a5b7bc14 100644 --- a/compiler/ml/variant_runtime.mli +++ b/compiler/ml/variant_runtime.mli @@ -38,18 +38,10 @@ type block_type = | ObjectType | UnknownType -(** A runtime tag written explicitly with [@as]. Unlike [tag_type], this can - never describe an inferred untagged payload shape. *) -type declared_tag = - | Declared_string of string - | Declared_int of int - | Declared_float of string - | Declared_bigint of string - | Declared_bool of bool - | Declared_null - | Declared_undefined - -type tag_type = +(** The literal value a constructor is represented by: what [@as] states, or + the constructor's own name when it states nothing. Unlike [tag_type], this + can never describe an inferred untagged payload shape. *) +type literal_tag = | String of string | Int of int | Float of string @@ -57,9 +49,8 @@ type tag_type = | Bool of bool | Null | Undefined - | Untagged of block_type -val tag_type_of_declared : declared_tag -> tag_type +type tag_type = Literal of literal_tag | Untagged of block_type type tag = {name: string; tag_type: tag_type option} type block_runtime = {tag: tag; tag_name: string option; untagged: bool} From 085aaf95f7a623aec1c8dea04cc56174e6c28e4c Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Thu, 3 Sep 2026 17:49:56 +0200 Subject: [PATCH 06/10] Store a variant tag as the literal it can only be A constructor's stored tag could only ever be a declared literal: the untagged shape is synthesized during matching, at one place, from a payload's block type. The record now says so, and the two roles get separate names rather than one field standing for both: type tag = {name: string; literal: literal_tag option} type matchable_tag = {name: string; tag_type: tag_type option} val to_matchable_tag : tag -> matchable_tag so constructor_tag returns a literal_tag option, literal_tags and literal_cases are literal lists, and the coercion errors carry literals. Their readers stop unwrapping a case that could not occur -- printtyp's @as reconstruction loses its "should never happen" arm, and the overlap predicates in the untagged checks stop matching on Untagged to answer questions only a literal can answer. Three functions had no callers. tag_can_be_undefined guarded the optimisation removed in 244cdad95, which compiled {field: VariantCase} to field: VariantCase and made a single-case variant look exhaustive. get_tag_name was a one-line wrapper that 108aa8f06 inlined past. tag_type_to_user_visible_string is dead as of this commit: its Literal branch delegated to literal_tag_to_user_visible_string, which is what the narrowed errors call, and its Untagged branch was unreachable. Signed-off-by: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/js_dump.ml | 10 ++-- compiler/core/js_exp_make.mli | 3 +- compiler/core/lam_compile.ml | 10 ++-- compiler/core/lam_compile_const.ml | 4 +- .../gentype/translate_type_declarations.ml | 21 ++++--- compiler/ml/ast_untagged_variants.ml | 59 ++++++------------- compiler/ml/error_message_utils.ml | 2 +- compiler/ml/lambda.ml | 27 ++++----- compiler/ml/printtyp.ml | 8 +-- compiler/ml/typeopt.ml | 2 +- compiler/ml/variant_coercion.ml | 19 +++--- compiler/ml/variant_layout.ml | 9 +-- compiler/ml/variant_runtime.ml | 44 +++++++++----- compiler/ml/variant_runtime.mli | 18 +++++- 14 files changed, 111 insertions(+), 125 deletions(-) diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index d536189285..839f2ebcf6 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -936,16 +936,16 @@ and expression_desc cxt ~(level : int) f x : cxt = else ( Js_op.Lit tag_name, (* TAG:xx for inline records *) - match tag.tag_type with + match tag.literal with | None -> E.str p.name - | Some t -> E.tag_type t ) + | Some t -> E.literal_tag t ) :: tails in expression_desc cxt ~level f (Object (None, objs)) | Caml_block (el, _, Blk_constructor p) -> let not_is_cons = p.name <> Literals.cons in let {Variant_runtime.tag; tag_name; untagged} = p.runtime in - let tag_type = tag.tag_type in + let literal = tag.literal in let tag_name = Option.value tag_name ~default:L.tag in let objs = let tails = @@ -964,9 +964,9 @@ and expression_desc cxt ~(level : int) f x : cxt = else ( Js_op.Lit tag_name, (* TAG:xx *) - match tag_type with + match literal with | None -> E.str p.name - | Some t -> E.tag_type t ) + | Some t -> E.literal_tag t ) :: tails in let exp = diff --git a/compiler/core/js_exp_make.mli b/compiler/core/js_exp_make.mli index 2f090d348f..0c825d0093 100644 --- a/compiler/core/js_exp_make.mli +++ b/compiler/core/js_exp_make.mli @@ -161,6 +161,7 @@ val extension_assign : t -> int32 -> string -> t -> t val assign : ?comment:string -> t -> t -> t +val literal_tag : Variant_runtime.literal_tag -> t val tag_type : Variant_runtime.tag_type -> t val emit_check : t Ast_untagged_variants.Dynamic_checks.t -> t @@ -183,7 +184,7 @@ val is_type_number : ?comment:string -> t -> t val is_int_tag : ?has_null_undefined_other:bool * bool * bool -> t -> t val is_a_literal_case : - literal_cases:Variant_runtime.tag_type list -> + literal_cases:Variant_runtime.literal_tag list -> block_cases:Variant_runtime.block_type list -> t -> t diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index 8d1f4c46ec..dad8c9eb7a 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -173,7 +173,8 @@ let default_action ~saturated failaction = let tag_of_switch_key = function | Lambda.Switch_int _ -> None - | Switch_constructor (Constant tag) -> Some tag + | Switch_constructor (Constant tag) -> + Some (Variant_runtime.to_matchable_tag tag) | Switch_constructor (Block { @@ -181,7 +182,8 @@ let tag_of_switch_key = function block_type = Some block_type; }) -> Some {name; tag_type = Some (Untagged block_type)} - | Switch_constructor (Block {runtime = {untagged = false; tag}}) -> Some tag + | Switch_constructor (Block {runtime = {untagged = false; tag}}) -> + Some (Variant_runtime.to_matchable_tag tag) | Switch_constructor (Block {runtime = {untagged = true}; block_type = None}) -> assert false @@ -793,9 +795,7 @@ let compile output_prefix = && List.length sw_consts = 0 && eq_default sw_num_default sw_blocks_default then - let has_null_case = - List.mem (Variant_runtime.Literal Null) literal_cases - in + let has_null_case = List.mem Variant_runtime.Null literal_cases in compile_cases ~untagged ~cxt ~switch_exp:(if untagged then e else E.tag ~name:tag_name e) ~block_cases ~has_null_case ~default:sw_blocks_default sw_blocks diff --git a/compiler/core/lam_compile_const.ml b/compiler/core/lam_compile_const.ml index b38a6a6492..257d9cc84f 100644 --- a/compiler/core/lam_compile_const.ml +++ b/compiler/core/lam_compile_const.ml @@ -50,11 +50,11 @@ and translate (x : Lambda.structured_constant) : J.expression = | Const_js_null -> E.nil | Const_js_undefined {is_unit = true} -> E.unit | Const_js_undefined {is_unit = false} -> E.undefined - | Const_constructor {name; tag_type = None} -> + | Const_constructor {name; literal = None} -> (* The runtime representation of a constant constructor is its name, except for the list constructor [] which is the number 0 *) if name = "[]" then E.int 0l ~comment:"[]" else E.str name - | Const_constructor {tag_type = Some t} -> E.tag_type t + | Const_constructor {literal = Some t} -> E.literal_tag t | Const_int i -> E.int i | Const_assertfalse -> E.int 0l ~comment:"assert_false" | Const_char i -> Js_of_lam_string.const_char i diff --git a/compiler/gentype/translate_type_declarations.ml b/compiler/gentype/translate_type_declarations.ml index 6ad4475935..542fb5b80a 100644 --- a/compiler/gentype/translate_type_declarations.ml +++ b/compiler/gentype/translate_type_declarations.ml @@ -41,17 +41,16 @@ let create_polyvariant_case (label, attributes) = } let create_variant_case label = function - | Some (Variant_runtime.Literal declared) -> ( - match declared with - | String label -> - {label_js = StringLabel (Emit_text.escape_string_contents label)} - | Int label -> {label_js = IntLabel (string_of_int label)} - | Float label -> {label_js = FloatLabel label} - | BigInt label -> {label_js = IntLabel label} - | Bool label -> {label_js = BoolLabel label} - | Null -> {label_js = NullLabel} - | Undefined -> {label_js = UndefinedLabel}) - | Some (Variant_runtime.Untagged _) | None -> {label_js = StringLabel label} + | Some (Variant_runtime.String label) -> + {label_js = StringLabel (Emit_text.escape_string_contents label)} + | Some (Variant_runtime.Int label) -> + {label_js = IntLabel (string_of_int label)} + | Some (Variant_runtime.Float label) -> {label_js = FloatLabel label} + | Some (Variant_runtime.BigInt label) -> {label_js = IntLabel label} + | Some (Variant_runtime.Bool label) -> {label_js = BoolLabel label} + | Some Variant_runtime.Null -> {label_js = NullLabel} + | Some Variant_runtime.Undefined -> {label_js = UndefinedLabel} + | None -> {label_js = StringLabel label} (** * Rename record fields. diff --git a/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml index 2fe4c8d450..dddc716050 100644 --- a/compiler/ml/ast_untagged_variants.ml +++ b/compiler/ml/ast_untagged_variants.ml @@ -79,7 +79,7 @@ let block_type_to_user_visible_string = function Can be a literal (case with no payload), or a block (case with payload). In the case of block it can be tagged or untagged. *) -let declared_tag_to_user_visible_string = function +let literal_tag_to_user_visible_string = function | String _ -> "string" | Int _ -> "int" | Float _ -> "float" @@ -88,10 +88,6 @@ let declared_tag_to_user_visible_string = function | Null -> "null" | Undefined -> "undefined" -let tag_type_to_user_visible_string = function - | Literal d -> declared_tag_to_user_visible_string d - | Untagged block_type -> block_type_to_user_visible_string block_type - let untagged = "unboxed" let block_type_can_be_undefined = function @@ -100,13 +96,6 @@ let block_type_can_be_undefined = function false | UnknownType -> true -let tag_can_be_undefined tag = - match tag.tag_type with - | None -> false - | Some (Literal Undefined) -> true - | Some (Literal _) -> false - | Some (Untagged block_type) -> block_type_can_be_undefined block_type - let has_untagged (attrs : Parsetree.attributes) = Ext_list.exists attrs (function {txt}, _ -> txt = untagged) @@ -218,11 +207,8 @@ let process_tag_name (attrs : Parsetree.attributes) = | _ -> ()); !st -let get_tag_name (cstr : Types.constructor_declaration) = - process_tag_name cstr.cd_attributes - (* A constructor the compiler generates itself carries no annotations. *) -let generated_tag ~name = {name; tag_type = None} +let generated_tag ~name = {name; literal = None} let generated_block_runtime ~name = {tag = generated_tag ~name; tag_name = None; untagged = false} @@ -292,20 +278,17 @@ let check_invariant ~is_untagged_def ~(consts : (Location.t * tag) list) then raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneBoolean)); () in - let check_literal ~is_const ~loc (literal : tag) = - match literal.tag_type with - | None -> add_string_literal ~is_const ~loc literal.name - | Some (Untagged _) -> () - | Some (Literal d) -> ( - match d with - | String s -> add_string_literal ~is_const ~loc s - | Int i -> add_nonstring_literal ~is_const ~loc (string_of_int i) - | Float f -> add_nonstring_literal ~is_const ~loc f - | BigInt i -> add_nonstring_literal ~is_const ~loc i - | Bool b -> - add_nonstring_literal ~is_const ~loc (if b then "true" else "false") - | Null -> add_nonstring_literal ~is_const ~loc "null" - | Undefined -> add_nonstring_literal ~is_const ~loc "undefined") + let check_literal ~is_const ~loc (tag : tag) = + match tag.literal with + | None -> add_string_literal ~is_const ~loc tag.name + | Some (String s) -> add_string_literal ~is_const ~loc s + | Some (Int i) -> add_nonstring_literal ~is_const ~loc (string_of_int i) + | Some (Float f) -> add_nonstring_literal ~is_const ~loc f + | Some (BigInt i) -> add_nonstring_literal ~is_const ~loc i + | Some (Bool b) -> + add_nonstring_literal ~is_const ~loc (if b then "true" else "false") + | Some Null -> add_nonstring_literal ~is_const ~loc "null" + | Some Undefined -> add_nonstring_literal ~is_const ~loc "undefined" in Ext_list.rev_iter consts (fun (loc, literal) -> @@ -334,11 +317,7 @@ let check_invariant ~is_untagged_def ~(consts : (Location.t * tag) list) check_literal ~is_const:false ~loc block.runtime.tag) let get_cstr_loc_tag (cstr : Types.constructor_declaration) = - ( cstr.cd_loc, - { - name = Ident.name cstr.cd_id; - tag_type = Option.map (fun d -> Literal d) cstr.cd_runtime_tag; - } ) + (cstr.cd_loc, {name = Ident.name cstr.cd_id; literal = cstr.cd_runtime_tag}) let check_tag_field_conflicts (cstrs : Types.constructor_declaration list) = List.iter @@ -407,13 +386,9 @@ module Dynamic_checks = struct let ( ||| ) x y = bin Or x y let ( &&& ) x y = bin And x y - let rec is_a_literal_case ~(literal_cases : tag_type list) ~block_cases + let rec is_a_literal_case ~(literal_cases : literal_tag list) ~block_cases ~list_literal_cases (e : _ t) = - let overlaps p = - Ext_list.exists literal_cases (function - | Literal d -> p d - | Untagged _ -> false) - in + let overlaps p = Ext_list.exists literal_cases p in let literals_overlaps_with_string () = overlaps (function | String _ -> true @@ -439,7 +414,7 @@ module Dynamic_checks = struct | Null -> true | _ -> false) in - let is_literal_case (t : tag_type) : _ t = e == tag_type t in + let is_literal_case (t : literal_tag) : _ t = e == tag_type (Literal t) in let is_not_block_case (c : block_type) : _ t = match c with | StringType diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index 7ec18b9519..4ee3f1aeaf 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -708,7 +708,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf let constructor_name = Ident.name cd.cd_id in let runtime_repr = match Variant_runtime.constructor_tag layout position with - | Some (Literal (String s)) -> Some s (* @as("string_value") *) + | Some (String s) -> Some s (* @as("string_value") *) | Some _ -> None (* @as with non-string values *) | None -> Some constructor_name (* No @as, use constructor name *) in diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 8c7c32c898..825030ccc1 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -418,8 +418,8 @@ let const_unit = Const_js_undefined {is_unit = true} let const_constructor (tag : Variant_runtime.tag) = if tag.name = "()" then const_unit else - match tag.tag_type with - | Some (Variant_runtime.Literal (Int v)) -> Const_int (Int32.of_int v) + match tag.literal with + | Some (Variant_runtime.Int v) -> Const_int (Int32.of_int v) | _ -> Const_constructor tag (* A constructor with an optional shape carries no payload when constant. *) @@ -800,7 +800,7 @@ let switch lam (lam_switch : lambda_switch) : t = match key with | Switch_int ordinal when ordinal = i -> Some action | Switch_constructor - (Constant {tag_type = Some (Variant_runtime.Literal (Int value))}) + (Constant {literal = Some (Variant_runtime.Int value)}) when value = i -> Some action | Switch_int _ | Switch_constructor _ -> None) @@ -881,8 +881,8 @@ let prim ~primitive:(prim : primitive) ~args loc : t = | Cneq -> a <> b | _ -> assert false) | ( Pintcomp ((Ceq | Cneq) as op), - Const_constructor {name = a; tag_type = None}, - Const_constructor {name = b; tag_type = None} ) -> + Const_constructor {name = a; literal = None}, + Const_constructor {name = b; literal = None} ) -> (* Both runtime representations are the constructor names *) Lift.bool (match op with @@ -1041,18 +1041,15 @@ let rec eval_const_as_bool (v : structured_constant) : bool option = | Const_bigint _ | Const_block _ -> Some true | Const_some b -> eval_const_as_bool b - | Const_constructor {name; tag_type} -> ( + | Const_constructor {name; literal} -> ( (* Truthiness of the canonical runtime representation *) - match tag_type with + match literal with | None -> Some (name <> "[]") (* the name string; [] is the number 0 *) - | Some (Untagged _) -> None - | Some (Literal d) -> ( - match d with - | String s -> Some (s <> "") - | Int i -> Some (i <> 0) - | Bool b -> Some b - | Null | Undefined -> Some false - | Float _ | BigInt _ -> None)) + | Some (String s) -> Some (s <> "") + | Some (Int i) -> Some (i <> 0) + | Some (Bool b) -> Some b + | Some (Null | Undefined) -> Some false + | Some (Float _ | BigInt _) -> None) let if_ (a : t) (b : t) (c : t) : t = match a with diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index a39bcf80db..40a0a826dc 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -891,8 +891,8 @@ and tree_of_constructor ?printing_context ~layout ~position cd = | BigInt s -> Printf.sprintf "@as(%sn)" s in match Variant_runtime.constructor_tag layout position with - | Some (Literal d) -> Some (as_annotation d) - | Some (Untagged _) (* should never happen *) | None -> None + | Some d -> Some (as_annotation d) + | None -> None in let arg () = tree_of_constructor_arguments ?printing_context cd.cd_args in match cd.cd_res with @@ -1556,7 +1556,7 @@ let print_variant_runtime_representation_issue ppf variant_name @{@as@} payload that has a runtime representation of \ @{%s@}, which is not compatible with the expected @{%s@}." constructor_name (Path.name variant_name) - (Ast_untagged_variants.tag_type_to_user_visible_string as_payload) + (Ast_untagged_variants.literal_tag_to_user_visible_string as_payload) (Path.name expected_typename) | Mismatched_unboxed_payload _ -> () | Mismatched_as_payload {constructor_name; expected_typename; as_payload} -> @@ -1571,7 +1571,7 @@ let print_variant_runtime_representation_issue ppf variant_name fprintf ppf "an @{@as@} payload that gives it the runtime type of \ @{%s@}." - (Ast_untagged_variants.tag_type_to_user_visible_string payload)); + (Ast_untagged_variants.literal_tag_to_user_visible_string payload)); fprintf ppf "@ That runtime representation is not compatible with the expected \ runtime representation of @{%s@}." diff --git a/compiler/ml/typeopt.ml b/compiler/ml/typeopt.ml index 8a8e215cbe..8c64055eab 100644 --- a/compiler/ml/typeopt.ml +++ b/compiler/ml/typeopt.ml @@ -79,7 +79,7 @@ let rec type_cannot_contain_undefined (typ : Types.type_expr) (env : Env.t) = | Variant_runtime.Block {runtime = {tag; untagged}} -> (tag, untagged) in - tag.tag_type <> Some (Variant_runtime.Literal Undefined) + tag.literal <> Some Variant_runtime.Undefined && ((not payload_is_unboxed) || match cd.cd_args with diff --git a/compiler/ml/variant_coercion.ml b/compiler/ml/variant_coercion.ml index fb5ec466ef..59c2052ad2 100644 --- a/compiler/ml/variant_coercion.ml +++ b/compiler/ml/variant_coercion.ml @@ -6,12 +6,12 @@ type variant_runtime_representation_issue = | Mismatched_as_payload of { constructor_name: string; expected_typename: Path.t; - as_payload: Variant_runtime.tag_type option; + as_payload: Variant_runtime.literal_tag option; } | As_payload_not_elgible_for_coercion of { constructor_name: string; expected_typename: Path.t; - as_payload: Variant_runtime.tag_type; + as_payload: Variant_runtime.literal_tag; } | Inline_record_cannot_be_coerced of {constructor_name: string} | Cannot_coerce_non_unboxed_with_payload of { @@ -76,14 +76,11 @@ let variant_has_same_runtime_representation_as_target ~(target_path : Path.t) with no such type cannot be coerced at all. *) let coercion = match as_payload with - | None -> `Coerces_to Predef.path_string - | Some (Literal (String _)) -> `Coerces_to Predef.path_string - | Some (Literal (Int _)) -> `Coerces_to Predef.path_int - | Some (Literal (Float _)) -> `Coerces_to Predef.path_float - | Some (Literal (BigInt _)) -> `Coerces_to Predef.path_bigint - | Some ((Literal (Null | Undefined | Bool _) | Untagged _) as payload) - -> - `Not_eligible payload + | None | Some (String _) -> `Coerces_to Predef.path_string + | Some (Int _) -> `Coerces_to Predef.path_int + | Some (Float _) -> `Coerces_to Predef.path_float + | Some (BigInt _) -> `Coerces_to Predef.path_bigint + | Some ((Null | Undefined | Bool _) as payload) -> `Not_eligible payload in match coercion with | `Coerces_to path when Path.same target_path path -> None @@ -254,7 +251,7 @@ let can_coerce_polyvariant_to_variant ~row_fields ~variant_constructors ~layout |> List.mapi (fun position (c : Types.constructor_declaration) -> let constructor_name = Ident.name c.cd_id in match Variant_runtime.constructor_tag layout position with - | Some (Literal (String as_runtime_string)) -> + | Some (String as_runtime_string) -> (* `@as("")`, does the configured string match the polyvariant value? *) as_runtime_string = polyvariant_value | Some _ -> diff --git a/compiler/ml/variant_layout.ml b/compiler/ml/variant_layout.ml index f67e8342d3..b84fb8455a 100644 --- a/compiler/ml/variant_layout.ml +++ b/compiler/ml/variant_layout.ml @@ -65,14 +65,7 @@ let layout_from_type_variant ~(configuration : configuration) ~env { runtime = { - tag = - { - name = Ident.name cstr.cd_id; - tag_type = - Option.map - (fun d -> Variant_runtime.Literal d) - cstr.cd_runtime_tag; - }; + tag = {name = Ident.name cstr.cd_id; literal = cstr.cd_runtime_tag}; tag_name = process_tag_name cstr.cd_attributes; untagged = process_untagged cstr.cd_attributes; }; diff --git a/compiler/ml/variant_runtime.ml b/compiler/ml/variant_runtime.ml index cfab52a001..5ee89df843 100644 --- a/compiler/ml/variant_runtime.ml +++ b/compiler/ml/variant_runtime.ml @@ -88,7 +88,12 @@ type tag_type = | Literal of literal_tag (* literal or tagged block *) | Untagged of block_type (* untagged block *) -type tag = {name: string; tag_type: tag_type option} +type tag = {name: string; literal: literal_tag option} +(** A constructor's name and optional explicitly declared runtime literal. *) + +type matchable_tag = {name: string; tag_type: tag_type option} +(** A constructor tag widened for matching, where an untagged payload shape + can participate alongside declared literals. *) type block_runtime = {tag: tag; tag_name: string option; untagged: bool} (** Runtime information shared by construction and pattern matching for a @@ -98,6 +103,11 @@ type block_runtime = {tag: tag; tag_name: string option; untagged: bool} type block = {runtime: block_runtime; block_type: block_type option} +(* Matching compares against a wider notion of tag than a declaration can + state, so a stored tag widens on its way into a check. *) +let to_matchable_tag ({name; literal} : tag) : matchable_tag = + {name; tag_type = Option.map (fun literal -> Literal literal) literal} + type constructor_case = Constant of tag | Block of block type configuration = {unboxed: bool; tag_name: string option} @@ -109,7 +119,7 @@ type matching_facts = { block_types: block_type list; (** Runtime shapes of constructors represented directly by their payload. Tagged object constructors do not appear here. *) - literal_tags: tag_type list; + literal_tags: literal_tag list; (** Runtime values of all nullary constructors. *) has_null: bool; has_undefined: bool; @@ -151,8 +161,8 @@ let constructor_at (layout : layout) position = layout.constructors.(position) let constructor_tag layout position = match constructor_at layout position with - | Constant tag -> tag.tag_type - | Block {runtime = {tag}} -> tag.tag_type + | Constant tag -> tag.literal + | Block {runtime = {tag}} -> tag.literal let constructor_is_untagged layout position = match constructor_at layout position with @@ -189,17 +199,19 @@ let compute_matching_facts ~tag_name (constructors : constructor_case array) : let has_other_literal = ref false in Array.iter (function - | Constant {name; tag_type} -> ( - let tag = - match tag_type with - | Some tag -> tag - | None -> Literal (String name) + | Constant {name; literal} -> ( + (* Without an [@as], a nullary constructor is its own name. *) + let literal = + match literal with + | Some literal -> literal + | None -> String name in - literal_tags := tag :: !literal_tags; - match tag with - | Literal Null -> has_null := true - | Literal Undefined -> has_undefined := true - | Literal _ | Untagged _ -> has_other_literal := true) + literal_tags := literal :: !literal_tags; + match literal with + | Null -> has_null := true + | Undefined -> has_undefined := true + | String _ | Int _ | Float _ | BigInt _ | Bool _ -> + has_other_literal := true) | Block {block_type} -> ( match block_type with | Some block_type -> block_types := block_type :: !block_types @@ -244,10 +256,10 @@ let plain_layout (cases : (string * bool (* has payload *)) list) : layout_ref = Block { runtime = - {tag = {name; tag_type = None}; tag_name = None; untagged = false}; + {tag = {name; literal = None}; tag_name = None; untagged = false}; block_type = None; } - else Constant {name; tag_type = None} + else Constant {name; literal = None} in ref (Complete diff --git a/compiler/ml/variant_runtime.mli b/compiler/ml/variant_runtime.mli index e6a5b7bc14..7dc77ad07a 100644 --- a/compiler/ml/variant_runtime.mli +++ b/compiler/ml/variant_runtime.mli @@ -52,10 +52,22 @@ type literal_tag = type tag_type = Literal of literal_tag | Untagged of block_type -type tag = {name: string; tag_type: tag_type option} +type tag = {name: string; literal: literal_tag option} +(** A constructor's name and optional explicitly declared runtime literal. *) + +type matchable_tag = {name: string; tag_type: tag_type option} +(** A constructor tag widened for matching, where an untagged payload shape + can participate alongside declared literals. *) + type block_runtime = {tag: tag; tag_name: string option; untagged: bool} + type block = {runtime: block_runtime; block_type: block_type option} type constructor_case = Constant of tag | Block of block + +val to_matchable_tag : tag -> matchable_tag +(** Widen a tag as stated by a declaration into one a match can compare + against, which also covers an untagged payload's shape. *) + type configuration = { unboxed: bool; (** Whether the declaration carries [@unboxed]. This is retained even @@ -69,7 +81,7 @@ type configuration = { type matching_facts = { tag_name: string option; block_types: block_type list; - literal_tags: tag_type list; + literal_tags: literal_tag list; has_null: bool; has_undefined: bool; has_other_literal: bool; @@ -88,7 +100,7 @@ val get_layout : layout_ref -> layout val matching_facts : layout -> matching_facts val configuration : layout -> configuration val constructor_at : layout -> int -> constructor_case -val constructor_tag : layout -> int -> tag_type option +val constructor_tag : layout -> int -> literal_tag option val constructor_is_untagged : layout -> int -> bool val representation : constructor_reference -> constructor_case val length : layout -> int From 900e3096bfedd2c3114a023322cec837a1cab08a Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Thu, 3 Sep 2026 17:58:35 +0200 Subject: [PATCH 07/10] Read an @as attribute in one place Three functions read the single @as an item may carry, differing only in the payload they accept: a string, an int, or any of int, string and json. Each repeated the same skeleton -- find the attribute, reject a second one, mark it used -- so that part is now written once and takes the decoder: let as_string (attrs : t) : string option = single_as attrs ~decode:(fun ~loc payload -> match Ast_payload.semantic_string_of_payload payload with | None -> Bs_syntaxerr.err loc Expect_string_literal | Some v -> v) The decoder runs before a second attribute is looked at, so a malformed payload is still reported ahead of the duplicate that follows it rather than the other way round. Renamed from iter_process_bs_string_as and its siblings, which described the traversal rather than the result and kept a bs prefix that no longer means anything. Signed-off-by: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/frontend/ast_attributes.ml | 118 +++++++++------------- compiler/frontend/ast_attributes.mli | 6 +- compiler/frontend/ast_derive_js_mapper.ml | 2 +- compiler/frontend/ast_external_process.ml | 12 +-- compiler/frontend/ast_polyvar.ml | 6 +- 5 files changed, 60 insertions(+), 84 deletions(-) diff --git a/compiler/frontend/ast_attributes.ml b/compiler/frontend/ast_attributes.ml index 078cd29e15..80812e1fd0 100644 --- a/compiler/frontend/ast_attributes.ml +++ b/compiler/frontend/ast_attributes.ml @@ -133,20 +133,26 @@ let iter_process_bs_string_int_unwrap_uncurry (attrs : t) = Bs_syntaxerr.err loc (Conflict_attributes (List.map (fun (v, _) -> attr_name v) conflicting)) -let iter_process_bs_string_as (attrs : t) : string option = +(* The one [@as] an item may carry, read with the payload the caller expects. + The first is decoded before a second is looked at, so a malformed payload is + reported ahead of the duplicate it precedes. *) +let single_as ~decode (attrs : t) = let st = ref None in Ext_list.iter attrs (fun (({txt; loc}, payload) as attr) -> - match txt with - | "as" -> + if txt = "as" then if !st = None then ( - match Ast_payload.semantic_string_of_payload payload with - | None -> Bs_syntaxerr.err loc Expect_string_literal - | Some v -> - Used_attributes.mark_used_attribute attr; - st := Some v) - else raise (Ast_untagged_variants.Error (loc, Duplicated_bs_as)) - | _ -> ()); + let value = decode ~loc payload in + Used_attributes.mark_used_attribute attr; + st := Some value) + else raise (Ast_untagged_variants.Error (loc, Duplicated_bs_as))); !st + +let as_string (attrs : t) : string option = + single_as attrs ~decode:(fun ~loc payload -> + match Ast_payload.semantic_string_of_payload payload with + | None -> Bs_syntaxerr.err loc Expect_string_literal + | Some v -> v) + let has_bs_optional (attrs : t) : bool = Ext_list.exists attrs (fun (({txt}, _) as attr) -> match txt with @@ -161,68 +167,42 @@ let has_unwrap_attr (attrs : t) : bool = | "let.unwrap" -> true | _ -> false) -let iter_process_bs_int_as (attrs : t) = - let st = ref None in - Ext_list.iter attrs (fun (({txt; loc}, payload) as attr) -> - match txt with - | "as" -> - if !st = None then ( - match Ast_payload.is_single_int payload with - | None -> Bs_syntaxerr.err loc Expect_int_literal - | Some _ as v -> - Used_attributes.mark_used_attribute attr; - st := v) - else raise (Ast_untagged_variants.Error (loc, Duplicated_bs_as)) - | _ -> ()); - !st +let as_int (attrs : t) = + single_as attrs ~decode:(fun ~loc payload -> + match Ast_payload.is_single_int payload with + | None -> Bs_syntaxerr.err loc Expect_int_literal + | Some v -> v) type as_const_payload = Int of int | Str of string | Json of string -let iter_process_bs_string_or_int_as (attrs : Parsetree.attributes) = - let st = ref None in - Ext_list.iter attrs (fun (({txt; loc}, payload) as attr) -> - match txt with - | "as" -> - if !st = None then ( - Used_attributes.mark_used_attribute attr; - match Ast_payload.is_single_int payload with - | Some v -> st := Some (Int v) - | None -> ( - match Ast_payload.semantic_string_of_payload payload with - | Some s -> st := Some (Str s) - | None -> ( - match payload with - | PStr - [ - { - pstr_desc = - Pstr_eval - ( { - pexp_desc = Pexp_constant (Pconst_json s); - pexp_loc; - _; - }, - _ ); - _; - }; - ] -> ( - st := Some (Json s); - (* Check that it is a valid object literal. *) - match - Classify_function.classify - ~check: - ( pexp_loc, - Bs_flow_ast_utils.flow_deli_offset (Some "json") ) - s - with - | Js_literal _ -> () - | _ -> - Location.raise_errorf ~loc:pexp_loc - "an object literal expected") - | _ -> Bs_syntaxerr.err loc Expect_int_or_string_or_json_literal))) - else raise (Ast_untagged_variants.Error (loc, Duplicated_bs_as)) - | _ -> ()); - !st +let as_const (attrs : t) = + single_as attrs ~decode:(fun ~loc payload -> + match Ast_payload.is_single_int payload with + | Some v -> Int v + | None -> ( + match Ast_payload.semantic_string_of_payload payload with + | Some s -> Str s + | None -> ( + match payload with + | PStr + [ + { + pstr_desc = + Pstr_eval + ({pexp_desc = Pexp_constant (Pconst_json s); pexp_loc}, _); + }; + ] -> ( + (* Check that it is a valid object literal. *) + match + Classify_function.classify + ~check: + (pexp_loc, Bs_flow_ast_utils.flow_deli_offset (Some "json")) + s + with + | Js_literal _ -> Json s + | _ -> + Location.raise_errorf ~loc:pexp_loc "an object literal expected") + | _ -> Bs_syntaxerr.err loc Expect_int_or_string_or_json_literal))) let locg = Location.none diff --git a/compiler/frontend/ast_attributes.mli b/compiler/frontend/ast_attributes.mli index 94bfae67bf..a812bd9b1f 100644 --- a/compiler/frontend/ast_attributes.mli +++ b/compiler/frontend/ast_attributes.mli @@ -38,16 +38,16 @@ type derive_attr = {bs_deriving: Ast_payload.action list option} [@@unboxed] val iter_process_bs_string_int_unwrap_uncurry : t -> [`Nothing | `String | `Int | `Ignore | `Unwrap] -val iter_process_bs_string_as : t -> string option +val as_string : t -> string option val has_bs_optional : t -> bool val has_unwrap_attr : t -> bool -val iter_process_bs_int_as : t -> int option +val as_int : t -> int option type as_const_payload = Int of int | Str of string | Json of string -val iter_process_bs_string_or_int_as : t -> as_const_payload option +val as_const : t -> as_const_payload option val process_derive_type : t -> derive_attr * t diff --git a/compiler/frontend/ast_derive_js_mapper.ml b/compiler/frontend/ast_derive_js_mapper.ml index b8ccadda9e..ea8fb63837 100644 --- a/compiler/frontend/ast_derive_js_mapper.ml +++ b/compiler/frontend/ast_derive_js_mapper.ml @@ -118,7 +118,7 @@ let build_map (row_fields : Parsetree.row_field list) = (match tag with | Rtag ({txt}, attrs, _, []) -> let name : string = - match Ast_attributes.iter_process_bs_string_as attrs with + match Ast_attributes.as_string attrs with | Some name -> has_bs_as := true; name diff --git a/compiler/frontend/ast_external_process.ml b/compiler/frontend/ast_external_process.ml index b64aae652a..c4f120670f 100644 --- a/compiler/frontend/ast_external_process.ml +++ b/compiler/frontend/ast_external_process.ml @@ -75,7 +75,7 @@ let refine_arg_type ~(nolabel : bool) (ptyp : Ast_core_type.t) : External_arg_spec.attr = if ptyp.ptyp_desc = Ptyp_any then let ptyp_attrs = ptyp.ptyp_attributes in - let payload = Ast_attributes.iter_process_bs_string_or_int_as ptyp_attrs in + let payload = Ast_attributes.as_const ptyp_attrs in match payload with | None -> spec_of_ptyp nolabel ptyp | Some cst -> ( @@ -98,7 +98,7 @@ let refine_obj_arg_type ~(nolabel : bool) (ptyp : Ast_core_type.t) : External_arg_spec.attr = if ptyp.ptyp_desc = Ptyp_any then ( let ptyp_attrs = ptyp.ptyp_attributes in - let payload = Ast_attributes.iter_process_bs_string_or_int_as ptyp_attrs in + let payload = Ast_attributes.as_const ptyp_attrs in (* when ppx start dropping attributes we should warn, there is a trade off whether we should warn dropped non bs attribute or not @@ -452,9 +452,7 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string) "expect label, optional, or unit here") | Labelled {txt = label} -> ( let field_name = - match - Ast_attributes.iter_process_bs_string_as param_type.attrs - with + match Ast_attributes.as_string param_type.attrs with | Some alias -> alias | None -> label in @@ -511,9 +509,7 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string) "%@obj label %s does not support %@unwrap arguments" label) | Optional {txt = label} -> ( let field_name = - match - Ast_attributes.iter_process_bs_string_as param_type.attrs - with + match Ast_attributes.as_string param_type.attrs with | Some alias -> alias | None -> label in diff --git a/compiler/frontend/ast_polyvar.ml b/compiler/frontend/ast_polyvar.ml index 43e74636bf..51d5bd1868 100644 --- a/compiler/frontend/ast_polyvar.ml +++ b/compiler/frontend/ast_polyvar.ml @@ -28,7 +28,7 @@ let map_row_fields_into_ints ptyp_loc (row_fields : Parsetree.row_field list) = match rtag with | Rtag ({txt}, attrs, true, []) -> let i = - match Ast_attributes.iter_process_bs_int_as attrs with + match Ast_attributes.as_int attrs with | Some i -> i | None -> i in @@ -49,7 +49,7 @@ let map_row_fields_into_strings ptyp_loc (row_fields : Parsetree.row_field list) match (nullary, tag) with | (`Nothing | `Null), Rtag ({txt}, attrs, true, []) -> let name = - match Ast_attributes.iter_process_bs_string_as attrs with + match Ast_attributes.as_string attrs with | Some name -> has_bs_as := true; name @@ -58,7 +58,7 @@ let map_row_fields_into_strings ptyp_loc (row_fields : Parsetree.row_field list) (`Null, (txt, name) :: acc) | (`Nothing | `NonNull), Rtag ({txt}, attrs, false, [_]) -> let name = - match Ast_attributes.iter_process_bs_string_as attrs with + match Ast_attributes.as_string attrs with | Some name -> has_bs_as := true; name From 6c0f6bf55da6bf34b7364579c3a19d389fcc8bb6 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Thu, 3 Sep 2026 18:03:22 +0200 Subject: [PATCH 08/10] Name the reader of an external argument's encoding iter_process_bs_string_int_unwrap_uncurry advertised uncurry, which it does not handle, and omitted ignore, which it does. It answers which of @string, @int, @ignore and @unwrap an external's argument carries, so it is now arg_encoding. Signed-off-by: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/frontend/ast_attributes.ml | 6 ++++-- compiler/frontend/ast_attributes.mli | 5 +++-- compiler/frontend/ast_external_process.ml | 5 +---- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/compiler/frontend/ast_attributes.ml b/compiler/frontend/ast_attributes.ml index 80812e1fd0..3fd092b421 100644 --- a/compiler/frontend/ast_attributes.ml +++ b/compiler/frontend/ast_attributes.ml @@ -105,8 +105,10 @@ let process_derive_type (attrs : t) : derive_attr * t = | Some _ -> Bs_syntaxerr.err loc Duplicated_bs_deriving) | _ -> (st, attr :: acc)) -(* duplicated attributes not allowed *) -let iter_process_bs_string_int_unwrap_uncurry (attrs : t) = +(* How an external's argument is encoded, from the one of [@string], [@int], + [@ignore] and [@unwrap] it carries. They are alternatives, so more than one + is a conflict. *) +let arg_encoding (attrs : t) = let attr_name = function | `String -> "string" | `Int -> "int" diff --git a/compiler/frontend/ast_attributes.mli b/compiler/frontend/ast_attributes.mli index a812bd9b1f..911cb7d96e 100644 --- a/compiler/frontend/ast_attributes.mli +++ b/compiler/frontend/ast_attributes.mli @@ -35,8 +35,9 @@ val has_await_payload : t -> bool type derive_attr = {bs_deriving: Ast_payload.action list option} [@@unboxed] -val iter_process_bs_string_int_unwrap_uncurry : - t -> [`Nothing | `String | `Int | `Ignore | `Unwrap] +val arg_encoding : t -> [`Nothing | `String | `Int | `Ignore | `Unwrap] +(** How an external's argument is encoded, from the one of [@string], [@int], + [@ignore] and [@unwrap] it carries. *) val as_string : t -> string option diff --git a/compiler/frontend/ast_external_process.ml b/compiler/frontend/ast_external_process.ml index c4f120670f..5d2e20c372 100644 --- a/compiler/frontend/ast_external_process.ml +++ b/compiler/frontend/ast_external_process.ml @@ -39,10 +39,7 @@ let variant_unwrap (row_fields : Parsetree.row_field list) : bool = let spec_of_ptyp (nolabel : bool) (ptyp : Parsetree.core_type) : External_arg_spec.attr = let ptyp_desc = ptyp.ptyp_desc in - match - Ast_attributes.iter_process_bs_string_int_unwrap_uncurry - ptyp.ptyp_attributes - with + match Ast_attributes.arg_encoding ptyp.ptyp_attributes with | `String -> ( match ptyp_desc with | Ptyp_variant (row_fields, Closed, None) -> From c0daad35c0ada2e530295f5ca608c9e564d69373 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Thu, 3 Sep 2026 18:14:17 +0200 Subject: [PATCH 09/10] Warn about an @as that does not name a record field Every @as on a record field was marked used, which made sense when the attribute was what the compiler read. Now the one that names the field is taken out of the attributes when the field is built, so an @as still there is either a second one, which the type checker rejects, or a payload that is not a name at all. @as(42) on a record field was accepted in silence: it renamed nothing and nothing reported it. Only the attribute the compiler acts on is marked now, so that case warns and a duplicate still reports just its own error rather than both. Signed-off-by: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- CHANGELOG.md | 1 + compiler/frontend/bs_ast_invariant.ml | 15 +++++++++++---- .../record_field_as_not_a_name.res.expected | 13 +++++++++++++ .../fixtures/record_field_as_not_a_name.res | 3 +++ 4 files changed, 28 insertions(+), 4 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/record_field_as_not_a_name.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/record_field_as_not_a_name.res diff --git a/CHANGELOG.md b/CHANGELOG.md index 036e81aa3f..19e3eb61c6 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -39,6 +39,7 @@ - Fix the side-effect analysis treating bigint exponentiation and bounds-checked array and string reads as pure, which let dead-code elimination drop an unused one that throws: `let _ = 2n ** -1n` no longer raised. https://github.com/rescript-lang/rescript/pull/8617 - Fix excessive parentheses and indentation in function assignments to refs, align record and array assignment formatting across refs and fields, and preserve function return-type parentheses and consistent JSX fragment layout in callbacks. https://github.com/rescript-lang/rescript/pull/8611 - Report an error instead of crashing when an integer in a variant constructor's `@as` annotation exceeds the compiler's integer range. https://github.com/rescript-lang/rescript/pull/8619 +- Warn about an `@as` on a record field whose payload does not name the field, such as `@as(42)`. It renamed nothing and was silently accepted. https://github.com/rescript-lang/rescript/pull/8619 - Fix a recursive module with an empty signature discarding its right-hand side. Lambda-to-Lam conversion rewrote `Pupdate_mod` to unit when the module's shape had no fields, dropping the primitive's arguments - one of which is the right-hand side - so `module rec M: {} = { let () = Console.log("effect") }` emitted nothing for `M`. The elision now happens where the bindings are produced, with the right-hand side still in hand. https://github.com/rescript-lang/rescript/pull/8608 - Fix a compiler crash on a polymorphic variant whose numeric name exceeds the `int32` range. `#99999999999("a")` and the same name in a pattern failed with `Failure("Int32.of_string")` and no location, because the range check ran in the frontend AST pass and matched only payload-free expressions. It now runs in `Typecore`, next to the integer literal decoding whose overflow error it mirrors, and covers both label positions. A bare `type t = [#99999999999]` still compiles, since nothing decodes a row field name. https://github.com/rescript-lang/rescript/pull/8608 - Object typing errors now describe fields directly: assigning to a field without `@set` reports that the field is not settable and suggests the annotation, and missing-property errors name the field instead of a phantom `"x#="` member. https://github.com/rescript-lang/rescript/pull/8597 diff --git a/compiler/frontend/bs_ast_invariant.ml b/compiler/frontend/bs_ast_invariant.ml index bc661a4b88..797fd15bbe 100644 --- a/compiler/frontend/bs_ast_invariant.ml +++ b/compiler/frontend/bs_ast_invariant.ml @@ -94,10 +94,17 @@ let emit_external_warnings : iterator = | _ -> super.expr self a); label_declaration = (fun self lbl -> - Ext_list.iter lbl.pld_attributes (fun attr -> - match attr with - | {txt = "as"}, _ -> Used_attributes.mark_used_attribute attr - | _ -> ()); + (* A field's [@as] is taken out of its attributes when it names the + field, so one still here is either a second one, which the type + checker rejects, or a payload that is not a name. The first is + reported already; the second is reported by nothing else, so let it + warn as the unused attribute it is. *) + Ext_list.iter lbl.pld_attributes + (fun (({txt}, payload) as attr : Parsetree.attribute) -> + if + txt = "as" + && Ast_payload.string_literal_of_payload payload <> None + then Used_attributes.mark_used_attribute attr); super.label_declaration self lbl); constructor_declaration = (fun self ({pcd_name = {txt; loc}} as ctr) -> diff --git a/tests/build_tests/super_errors/expected/record_field_as_not_a_name.res.expected b/tests/build_tests/super_errors/expected/record_field_as_not_a_name.res.expected new file mode 100644 index 0000000000..b1e1683b9a --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_field_as_not_a_name.res.expected @@ -0,0 +1,13 @@ + + Warning number 101 (configured as error) + /.../fixtures/record_field_as_not_a_name.res:3:11-13 + + 1 │ /* An @as that does not name the field renames nothing. Nothing else rep + │ orts + 2 │ it, so it warns as the unused attribute it is. */ + 3 │ type t = {@as(42) a: int} + 4 │ + + Unused attribute: @as +This attribute has no effect here. +For example, some attributes are only meaningful in externals. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/record_field_as_not_a_name.res b/tests/build_tests/super_errors/fixtures/record_field_as_not_a_name.res new file mode 100644 index 0000000000..b5fe358185 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/record_field_as_not_a_name.res @@ -0,0 +1,3 @@ +/* An @as that does not name the field renames nothing. Nothing else reports + it, so it warns as the unused attribute it is. */ +type t = {@as(42) a: int} From 8aa1c8f49f08eeac6b83a1cdd3777cee8d6408fb Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sat, 5 Sep 2026 02:11:18 +0200 Subject: [PATCH 10/10] Keep field renames in object spreads Signed-off-by: Cristiano Calcagno --- CHANGELOG.md | 1 + compiler/syntax/src/res_core.ml | 10 ++++++---- .../syntax_tests/data/printer/ObjectSpreadFieldAs.res | 3 +++ .../data/printer/expected/ObjectSpreadFieldAs.res.txt | 3 +++ 4 files changed, 13 insertions(+), 4 deletions(-) create mode 100644 tests/syntax_tests/data/printer/ObjectSpreadFieldAs.res create mode 100644 tests/syntax_tests/data/printer/expected/ObjectSpreadFieldAs.res.txt diff --git a/CHANGELOG.md b/CHANGELOG.md index 19e3eb61c6..0570947a2f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -37,6 +37,7 @@ #### :bug: Bug fix - Fix the side-effect analysis treating bigint exponentiation and bounds-checked array and string reads as pure, which let dead-code elimination drop an unused one that throws: `let _ = 2n ** -1n` no longer raised. https://github.com/rescript-lang/rescript/pull/8617 +- Preserve record field `@as` annotations when formatting object types containing spreads. https://github.com/rescript-lang/rescript/pull/8619 - Fix excessive parentheses and indentation in function assignments to refs, align record and array assignment formatting across refs and fields, and preserve function return-type parentheses and consistent JSX fragment layout in callbacks. https://github.com/rescript-lang/rescript/pull/8611 - Report an error instead of crashing when an integer in a variant constructor's `@as` annotation exceeds the compiler's integer range. https://github.com/rescript-lang/rescript/pull/8619 - Warn about an `@as` on a record field whose payload does not name the field, such as `@as(42)`. It renamed nothing and was silently accepted. https://github.com/rescript-lang/rescript/pull/8619 diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index e74bbf5655..81d2ea3a3d 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -5892,13 +5892,13 @@ and parse_spread_tail_classified ?current_type_name_path ?inline_types_context (* Object-style: build an object type that inherits the spread *) let obj_fields = let convert (ld : Parsetree.label_declaration) = - let ({Parsetree.pld_name; pld_type; pld_attributes; _} - : Parsetree.label_declaration) = + let ({Parsetree.pld_name; pld_type; _} : Parsetree.label_declaration) + = ld in match pld_name.txt with | "..." -> Parsetree.Oinherit pld_type - | _ -> Otag (pld_name, pld_attributes, pld_type) + | _ -> Otag (pld_name, Ast_helper.Type.field_attributes ld, pld_type) in Parsetree.Oinherit spread_typ :: List.map convert fields in @@ -5979,7 +5979,9 @@ and parse_record_or_object_decl ?current_type_name_path ?inline_types_context p Ext_list.map fields (fun ld -> match ld.pld_name.txt with | "..." -> Parsetree.Oinherit ld.pld_type - | _ -> Otag (ld.pld_name, ld.pld_attributes, ld.pld_type)) + | _ -> + Otag + (ld.pld_name, Ast_helper.Type.field_attributes ld, ld.pld_type)) in let dot_field = Parsetree.Oinherit typ in let typ_obj = Ast_helper.Typ.object_ (dot_field :: fields) Closed in diff --git a/tests/syntax_tests/data/printer/ObjectSpreadFieldAs.res b/tests/syntax_tests/data/printer/ObjectSpreadFieldAs.res new file mode 100644 index 0000000000..50cc59ef4f --- /dev/null +++ b/tests/syntax_tests/data/printer/ObjectSpreadFieldAs.res @@ -0,0 +1,3 @@ +type base = {"a": int} + +type extended = {...base, @as("renamed") "b": int} diff --git a/tests/syntax_tests/data/printer/expected/ObjectSpreadFieldAs.res.txt b/tests/syntax_tests/data/printer/expected/ObjectSpreadFieldAs.res.txt new file mode 100644 index 0000000000..50cc59ef4f --- /dev/null +++ b/tests/syntax_tests/data/printer/expected/ObjectSpreadFieldAs.res.txt @@ -0,0 +1,3 @@ +type base = {"a": int} + +type extended = {...base, @as("renamed") "b": int}