diff --git a/CHANGELOG.md b/CHANGELOG.md index a5851dee35..0570947a2f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -37,7 +37,10 @@ #### :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 - 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,12 +69,15 @@ - 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 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 - 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 +- 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 a3ed213e9f..d7bcb56821 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,33 @@ 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 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; 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/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.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_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/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..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 @@ -700,7 +702,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 @@ -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/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/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/core/record_attributes_check.ml b/compiler/core/record_attributes_check.ml deleted file mode 100644 index 7b30738b42..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 = Lambda.find_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 25c05907f9..dec9d67d4d 100644 --- a/compiler/ext/config.ml +++ b/compiler/ext/config.ml @@ -1,10 +1,10 @@ -let cmi_magic_number = "Caml1999I030" +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 = "ResImpl01304" +and ast_impl_magic_number = "ResImpl01306" -and ast_intf_magic_number = "ResIntf01304" +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 = "Caml1999T032" +and cmt_magic_number = "Caml1999T034" let load_path = ref ([] : string list) diff --git a/compiler/frontend/ast_attributes.ml b/compiler/frontend/ast_attributes.ml index 078cd29e15..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" @@ -133,20 +135,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 +169,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..911cb7d96e 100644 --- a/compiler/frontend/ast_attributes.mli +++ b/compiler/frontend/ast_attributes.mli @@ -35,19 +35,20 @@ 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 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_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/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..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) -> @@ -75,7 +72,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 +95,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 +449,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 +506,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 diff --git a/compiler/frontend/bs_ast_invariant.ml b/compiler/frontend/bs_ast_invariant.ml index 6aaf07f2a7..797fd15bbe 100644 --- a/compiler/frontend/bs_ast_invariant.ml +++ b/compiler/frontend/bs_ast_invariant.ml @@ -94,17 +94,21 @@ 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) -> - 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/gentype/translate_type_declarations.ml b/compiler/gentype/translate_type_declarations.ml index d5d89ffdec..542fb5b80a 100644 --- a/compiler/gentype/translate_type_declarations.ml +++ b/compiler/gentype/translate_type_declarations.ml @@ -50,7 +50,7 @@ let create_variant_case label = function | 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.Untagged _) | None -> {label_js = StringLabel label} + | None -> {label_js = StringLabel label} (** * Rename record fields. @@ -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..8c3bb97b0a 100644 --- a/compiler/ml/ast_helper.ml +++ b/compiler/ml/ast_helper.ml @@ -391,25 +391,134 @@ 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 + 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..7cb4a7104c 100644 --- a/compiler/ml/ast_helper.mli +++ b/compiler/ml/ast_helper.mli @@ -295,16 +295,30 @@ 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 -> ?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..327a805ebc 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -527,20 +527,22 @@ 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; 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..b2a6f5c66a 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -924,22 +924,23 @@ 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; 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..649bb0526b 100644 --- a/compiler/ml/ast_payload.ml +++ b/compiler/ml/ast_payload.ml @@ -57,13 +57,32 @@ 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, _); _}] -> semantic_string_of_expression expression | _ -> None -let is_single_int (x : t) : int option = +let single_int_source (x : t) = match x with | PStr [ @@ -77,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 @@ -134,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 ebaf2636d2..40a740ddcf 100644 --- a/compiler/ml/ast_payload.mli +++ b/compiler/ml/ast_payload.mli @@ -39,19 +39,19 @@ 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. *) 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 b089964677..dddc716050 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 -> @@ -74,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 literal_tag_to_user_visible_string = function | String _ -> "string" | Int _ -> "int" | Float _ -> "float" @@ -82,7 +87,6 @@ let tag_type_to_user_visible_string = function | Bool _ -> "bool" | Null -> "null" | Undefined -> "undefined" - | Untagged block_type -> block_type_to_user_visible_string block_type let untagged = "unboxed" @@ -92,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 (String _ | Int _ | Float _ | BigInt _ | Bool _ | Null) -> 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) @@ -110,37 +107,41 @@ 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 -> String (String_literal.string_semantic s) + | Pct_int source -> ( + match int_of_string_opt source with + | Some i -> Int i + | None -> raise (Error (loc, VariantAsIntegerOutOfRange source))) + | 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 + | 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. *) +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 @@ -206,17 +207,11 @@ 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; literal = None} -let constructor_tag ~name attrs = {name; tag_type = process_tag_type attrs} - -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 @@ -283,18 +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 + 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 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 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) -> @@ -323,7 +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, constructor_tag ~name:(Ident.name cstr.cd_id) cstr.cd_attributes) + (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 @@ -339,12 +333,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 @@ -356,8 +345,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 = @@ -379,11 +366,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 @@ -399,34 +386,35 @@ 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 p in let literals_overlaps_with_string () = - Ext_list.exists literal_cases (function + 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 - 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 @@ -535,5 +523,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/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/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/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/lambda.ml b/compiler/ml/lambda.ml index 68cad6e908..825030ccc1 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -61,36 +61,10 @@ let mutable_flag_of_tag_info (tag : tag_info) = | Blk_module_export _ | Blk_extension -> Immutable -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 )) - 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) - 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), _, _) -> - ( Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name, - lbl.lbl_optional )) - fields - in Blk_record_inlined {fields; name; num_nonconst; mutable_flag; runtime} let ref_tag_info : tag_info = @@ -108,13 +82,9 @@ 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 name = Fld_record {name} -let fld_record_extension (lbl : label) = - Fld_record_extension - {name = Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name} +let fld_record_extension name = Fld_record_extension {name} let ref_field_info : field_dbg_info = Fld_record {name = "contents"} @@ -124,20 +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 (Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name) +let fld_record_set name = Fld_record_set name -let fld_record_inline (lbl : label) = - Fld_record_inline - {name = Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name} +let fld_record_inline name = Fld_record_inline {name} -let fld_record_inline_set (lbl : label) = - Fld_record_inline_set - (Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name) +let fld_record_inline_set name = Fld_record_inline_set name -let fld_record_extension_set (lbl : label) = - Fld_record_extension_set - (Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name) +let fld_record_extension_set name = Fld_record_extension_set name type immediate_or_pointer = Immediate | Pointer @@ -455,7 +418,7 @@ 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 + match tag.literal with | Some (Variant_runtime.Int v) -> Const_int (Int32.of_int v) | _ -> Const_constructor tag @@ -837,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 {literal = Some (Variant_runtime.Int value)}) when value = i -> Some action | Switch_int _ | Switch_constructor _ -> None) @@ -918,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 @@ -1078,15 +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 (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 (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/lambda.mli b/compiler/ml/lambda.mli index d10c347064..4a3d81b577 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -52,22 +52,14 @@ 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 : - (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 -> @@ -88,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 @@ -103,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/parsetree.ml b/compiler/ml/parsetree.ml index 3044e9a08b..daccd0f858 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; @@ -534,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 d421bc2b6f..180e7184d2 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 @@ -1335,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 3172318eef..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; @@ -326,6 +327,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)); @@ -344,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 b15cecd6f3..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 @@ -729,10 +728,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/printtyp.ml b/compiler/ml/printtyp.ml index b878e6f7ed..40a0a826dc 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -881,15 +881,18 @@ 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 (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 @@ -1553,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} -> @@ -1568,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/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 new file mode 100644 index 0000000000..a2103af8ea --- /dev/null +++ b/compiler/ml/record_runtime.ml @@ -0,0 +1,56 @@ +(**************************************************************************) +(* *) +(* 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 declaration_name (lbl : Types.label_declaration) = + match lbl.ld_runtime_name with + | Some name -> name + | None -> Ident.name lbl.ld_id + +(* 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)) + +(* 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 new file mode 100644 index 0000000000..dc24d0abea --- /dev/null +++ b/compiler/ml/record_runtime.mli @@ -0,0 +1,26 @@ +(**************************************************************************) +(* *) +(* 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 declaration_name : Types.label_declaration -> string + +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 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..c4d2215d2a 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; @@ -251,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/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 aa7ed86148..820e48ccd5 100644 --- a/compiler/ml/typecore_record_rest.ml +++ b/compiler/ml/typecore_record_rest.ml @@ -27,14 +27,7 @@ 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_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 @@ -167,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/typedecl.ml b/compiler/ml/typedecl.ml index c962a37234..17ac9c44a8 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; @@ -475,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 @@ -511,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 -> @@ -538,6 +552,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 = @@ -564,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; @@ -574,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 e6fecd9210..ff1802caca 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; @@ -411,6 +412,7 @@ and label_declaration = { and constructor_declaration = { cd_id: Ident.t; cd_name: string loc; + 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 ab624cf008..618e893faf 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; @@ -517,6 +518,7 @@ and label_declaration = { and constructor_declaration = { cd_id: Ident.t; cd_name: string loc; + 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..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.Undefined + tag.literal <> Some Variant_runtime.Undefined && ((not payload_is_unboxed) || match cd.cd_args with diff --git a/compiler/ml/types.ml b/compiler/ml/types.ml index da22631825..94147e9034 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; @@ -175,6 +184,9 @@ and label_declaration = { and constructor_declaration = { cd_id: Ident.t; + 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; cd_res: type_expr option; cd_loc: Location.t; @@ -294,6 +306,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..47c2aaf147 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; @@ -272,6 +281,8 @@ and label_declaration = { and constructor_declaration = { cd_id: Ident.t; + cd_runtime_tag: Variant_runtime.literal_tag option; + (* The decoded [@as] value of the constructor. *) cd_args: constructor_arguments; cd_res: type_expr option; cd_loc: Location.t; @@ -380,6 +391,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/compiler/ml/variant_coercion.ml b/compiler/ml/variant_coercion.ml index 2aa704500a..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 { @@ -72,48 +72,27 @@ 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 | 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 + | `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 { diff --git a/compiler/ml/variant_layout.ml b/compiler/ml/variant_layout.ml index 9a3ec21fc9..b84fb8455a 100644 --- a/compiler/ml/variant_layout.ml +++ b/compiler/ml/variant_layout.ml @@ -63,7 +63,12 @@ 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; literal = 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..5ee89df843 100644 --- a/compiler/ml/variant_runtime.ml +++ b/compiler/ml/variant_runtime.ml @@ -67,21 +67,33 @@ type block_type = | ObjectType | UnknownType -(* - Type of the runtime representation of a tag. - 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. -*) -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 | BigInt of string | Bool of bool | Null - | Undefined (* literal or tagged block *) + | Undefined + +(* + Type of the runtime representation of a tag. + 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. +*) +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 @@ -91,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} @@ -102,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; @@ -144,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 @@ -182,17 +199,18 @@ 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 + | 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_tags := literal :: !literal_tags; + match literal with | Null -> has_null := true | Undefined -> has_undefined := true - | String _ | Int _ | Float _ | BigInt _ | Bool _ | Untagged _ -> + | String _ | Int _ | Float _ | BigInt _ | Bool _ -> has_other_literal := true) | Block {block_type} -> ( match block_type with @@ -238,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 0158adf830..7dc77ad07a 100644 --- a/compiler/ml/variant_runtime.mli +++ b/compiler/ml/variant_runtime.mli @@ -38,7 +38,10 @@ type block_type = | ObjectType | UnknownType -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 @@ -46,12 +49,25 @@ type tag_type = | Bool of bool | Null | Undefined - | Untagged of block_type -type tag = {name: string; tag_type: tag_type option} +type tag_type = Literal of literal_tag | Untagged of block_type + +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 @@ -65,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; @@ -84,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 diff --git a/compiler/ml/variant_type_spread.ml b/compiler/ml/variant_type_spread.ml index 08ed7629ce..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 @@ -174,6 +183,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_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_core.ml b/compiler/syntax/src/res_core.ml index adfb7f34e8..81d2ea3a3d 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; @@ -5891,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 @@ -5978,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 @@ -6049,17 +6052,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..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 = @@ -1867,7 +1868,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/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 674580a9eb..527cb64378 100644 --- a/tests/analysis_tests/tests/src/CompletionAttributes.res +++ b/tests/analysis_tests/tests/src/CompletionAttributes.res @@ -37,3 +37,8 @@ // let dd = %t // ^com +// 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 926cde0dcc..b4e8c6146c 100644 --- a/tests/analysis_tests/tests/src/expected/CompletionAttributes.res.txt +++ b/tests/analysis_tests/tests/src/expected/CompletionAttributes.res.txt @@ -275,3 +275,43 @@ 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": [] + } +] + +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/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/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/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} diff --git a/tests/ounit_tests/ounit_ast_mapper0_tests.ml b/tests/ounit_tests/ounit_ast_mapper0_tests.ml index 32e2564b04..21b215875e 100644 --- a/tests/ounit_tests/ounit_ast_mapper0_tests.ml +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -76,6 +76,111 @@ 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 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 @@ -709,4 +814,12 @@ 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; + "constructor_runtime_tag_reaches_ast0_as_an_attribute" + >:: test_constructor_runtime_tag_reaches_ast0_as_an_attribute; ] 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; 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/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/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/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/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} 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 +} 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 +}