From 601022f1aa9e5fd9d163a3e1dc3e9216673dfee2 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 24 Oct 2026 10:30:19 +0000 Subject: [PATCH 01/13] Let builtin types state their runtime shapes Why: Payload kinds had two sources: the shapes declarations state, and a list of builtin paths in get_block_type_from_typ. Builtins were outside the generic checks, so an annotation could not restate a builtin's kind and an interface could not state it over a builtin implementation. The declarations of `int`, `float`, `bigint`, `string`, `bool`, `dict`, `array` and `promise` in `Predef` state their shapes, and only tuples and function types are classified structurally. `@typeOf("number") type count = int` is a restatement, `@typeOf("string") type t = int` a contradiction, and an interface's `@typeOf("number") type t` accepts `type t = int`. Diagnostic modified (annotation over a builtin): Example: @typeOf("string") type t = int Before (diagnostic): @typeOf on a type abbreviation must describe an abstract type, or a type with the same annotation. The abbreviated type already has a runtime representation the compiler knows, or can be undefined. After (diagnostic): This annotation, @typeOf("string"), contradicts the abbreviated type, whose values are recognized by @typeOf("number"). Diagnostic modified (contradicting annotation): Example: @typeOf("symbol") type sym @typeOf("number") type t = sym Before (diagnostic): This annotation, @typeOf("number"), contradicts the abbreviated type's annotation, @typeOf("symbol"). After (diagnostic): This annotation, @typeOf("number"), contradicts the abbreviated type, whose values are recognized by @typeOf("symbol"). Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- compiler/ml/UntaggedVariants.md | 23 ++++++---- compiler/ml/ast_untagged_variants.ml | 3 +- compiler/ml/predef.ml | 18 ++++++-- compiler/ml/variant_layout.ml | 18 +------- ...nnotation_contradicts_builtin.res.expected | 8 ++++ ...notation_contradicts_manifest.res.expected | 2 +- ...runtime_annotation_contradicts_builtin.res | 1 + .../tests/src/untagged_builtin_alias_test.mjs | 42 +++++++++++++++++-- .../tests/src/untagged_builtin_alias_test.res | 37 ++++++++++++++++ 9 files changed, 118 insertions(+), 34 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/runtime_annotation_contradicts_builtin.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/runtime_annotation_contradicts_builtin.res diff --git a/compiler/ml/UntaggedVariants.md b/compiler/ml/UntaggedVariants.md index 070e42f22e..c8d495c090 100644 --- a/compiler/ml/UntaggedVariants.md +++ b/compiler/ml/UntaggedVariants.md @@ -106,15 +106,17 @@ into one kind: | a type declared with `@typeOf("k")` | kind `k` | `typeof x === "k"` | | anything else: an abstract type, a type variable, a variant, `list<_>`, an `@unboxed` record | unknown | no check | -The annotations of rule 5 are read first, on the type as written and on each -type it abbreviates. Otherwise the payload type is classified after expanding -abbreviations: `type ints = array` is an array case, and `type name = +The builtin types state their kinds in their declarations, as the +annotations of rule 5 do for declared types. The shape is read from the type +as written and from each type it abbreviates, and a tuple or a function type +is classified after expanding abbreviations: `type ints = array` is an array case, and `type name = string` a string case. A type is never recognized by its name. `@typeOf("number")` is the number kind, and `@typeOf("symbol")` is a kind of its own, with no builtin payload type. `@notUndefined` on an abstract type leaves it unknown. -- Implementation: `variant_layout.ml:get_block_type_from_typ`, - `get_block_type`, `recognized_as`. +- Implementation: `predef.ml` (the builtin shapes), + `variant_layout.ml:get_block_type_from_typ`, `get_block_type`, + `recognized_as`. - Tests: `spec_test` rules 4 (`kinds`, `tuples`, `aliasDict`, `instances`, `unknown`); fixtures `UntaggedConstructorMoreThanOneArg.res`, `UntaggedConstructorAttributeMoreThanOneArg.res`, `UntaggedNonUnary1.res`, @@ -155,7 +157,8 @@ superclass. An annotation on an abbreviation must agree with the abbreviated type. It can refine an abstract type that is not builtin and has no annotation, or repeat -the annotation of the abbreviated type. The type of a functor parameter, of a +what the abbreviated type is recognized by, as `@typeOf("number") type count = +int` does. The type of a functor parameter, of a recursive module being defined, and a locally abstract type `(type a)` are abstract only where they are declared: they stand for another type, so they cannot be refined. Only a private abbreviation can declare a subclass of the @@ -167,8 +170,8 @@ would `type dog = animal` or `type dog = phantom` with | Declaration | Error | Fixture | | --- | --- | --- | -| `@typeOf("string") type t = option`, `type t<'a> = 'a`, an abbreviation of `unit`, a builtin type, a record or a variant | @typeOf on a type abbreviation must describe an abstract type, ... | `runtime_annotation_on_option.res`, `runtime_annotation_on_type_variable.res` | -| `@typeOf("number") type t = sym` with `@typeOf("symbol") type sym` | This annotation, @typeOf("number"), contradicts the abbreviated type's annotation, @typeOf("symbol"). | `runtime_annotation_contradicts_manifest.res` | +| `@typeOf("string") type t = option`, `type t<'a> = 'a`, an abbreviation of `unit`, `list<_>`, a record or a variant | @typeOf on a type abbreviation must describe an abstract type, ... | `runtime_annotation_on_option.res`, `runtime_annotation_on_type_variable.res` | +| `@typeOf("number") type t = sym` with `@typeOf("symbol") type sym`, or `@typeOf("string") type t = int` | This annotation, @typeOf("number"), contradicts the abbreviated type, whose values are recognized by @typeOf("symbol"). | `runtime_annotation_contradicts_manifest.res`, `runtime_annotation_contradicts_builtin.res` | | `@instanceOf("Date") type date = X.t` in a functor of `X`, or over `(type a)` | @instanceOf cannot describe the type of a functor parameter, ... | `instance_of_functor_parameter.res`, `type_of_locally_abstract_type.res` | | `@instanceOf("Dog") type dog = animal`, `= animal`, or `= phantom` with `type phantom<'a> = animal` | A subclass must be a private abbreviation ... | `instance_of_public_subclass.res`, `instance_of_public_subclass_instance.res`, `instance_of_public_subclass_through_alias.res` | | `@instanceOf("Animal") type t = private dog` | Animal appears twice in this chain of abbreviations ... | `instance_of_class_twice_in_chain.res` | @@ -506,7 +509,9 @@ Type declarations in messages print the `@as` of nullary and tagged cases. A type for which an interface states a class or `typeof` (rule 5), through its own annotation or the type it abbreviates, must state the same one in the implementation, superclasses included: "Their runtime representations -differ". An interface that states none hides it. The same holds for functor +differ". A builtin type states its kind, so `@typeOf("number") type t` in an +interface accepts `type t = int` (`untagged_builtin_alias_test.res`). An +interface that states none hides it. The same holds for functor arguments, `with type` constraints and module type ascriptions. Within one variant a class is identified by its path, so two types of the same class are one case (rule 6); across a signature the two declarations must also state diff --git a/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml index c95d205096..bf6ebd3c41 100644 --- a/compiler/ml/ast_untagged_variants.ml +++ b/compiler/ml/ast_untagged_variants.ml @@ -162,7 +162,8 @@ let report_error ppf = attribute | RuntimeAnnotationContradictsManifest (outer, inner) -> fprintf ppf - "This annotation, %s, contradicts the abbreviated type's annotation, %s." + "This annotation, %s, contradicts the abbreviated type, whose values are \ + recognized by %s." outer inner | SubclassOfPublicAbbreviation (name, ancestor) -> fprintf ppf diff --git a/compiler/ml/predef.ml b/compiler/ml/predef.ml index 8ed35b7056..f7e134ca3a 100644 --- a/compiler/ml/predef.ml +++ b/compiler/ml/predef.ml @@ -258,11 +258,17 @@ let plain_variant (cstrs : Types.constructor_declaration list) = cstrs) ) let common_initial_env add_type add_extension empty_env = + (* What [typeof] or [instanceof] recognizes a builtin type's values by, + as an annotation states it for a declared type *) + let recognized_as block_type decl = + {decl with type_shape = Recognized_as block_type} + in let decl_bool = { decl_abstr with type_kind = plain_variant [cstr ident_false []; cstr ident_true []]; type_immediate = true; + type_shape = Recognized_as BooleanType; } and decl_unit = { @@ -278,6 +284,7 @@ let common_initial_env add_type add_extension empty_env = type_params = [tvar]; type_arity = 1; type_variance = [Variance.full]; + type_shape = Recognized_as (InstanceType Array); } and decl_iterable = let tvar = newgenvar () in @@ -333,6 +340,7 @@ let common_initial_env add_type add_extension empty_env = type_params = [tvar]; type_arity = 1; type_variance = [Variance.full]; + type_shape = Recognized_as ObjectType; } and decl_unknown = let tvar = newgenvar () in @@ -362,6 +370,8 @@ let common_initial_env add_type add_extension empty_env = type_params = [tvar]; type_arity = 1; type_variance = [Variance.covariant]; + type_shape = + Recognized_as (InstanceType (Class {name = "Promise"; ancestors = []})); } and decl_tagged_template = let tvar1, tvar2 = (newgenvar (), newgenvar ()) in @@ -393,10 +403,10 @@ let common_initial_env add_type add_extension empty_env = in empty_env |> add_type ident_bool decl_bool - |> add_type ident_int decl_abstr_imm - |> add_type ident_float decl_abstr - |> add_type ident_bigint decl_abstr - |> add_type ident_string decl_abstr + |> add_type ident_int (recognized_as NumberType decl_abstr_imm) + |> add_type ident_float (recognized_as NumberType decl_abstr) + |> add_type ident_bigint (recognized_as BigintType decl_abstr) + |> add_type ident_string (recognized_as StringType decl_abstr) |> add_type ident_unit decl_unit |> add_type ident_exn decl_exn |> add_type ident_option decl_option diff --git a/compiler/ml/variant_layout.ml b/compiler/ml/variant_layout.ml index 88f87e3991..449c7b73ac 100644 --- a/compiler/ml/variant_layout.ml +++ b/compiler/ml/variant_layout.ml @@ -162,23 +162,9 @@ let get_block_type_from_typ ~env (t : Types.type_expr) : block_type option = match recognized_as ~env t with | Some _ as declared -> declared | None -> ( - (* Builtin types have no declaration to annotate *) + (* Builtin types state their shapes in [Predef]; type expressions other + than constructors have no declaration *) match (Ctype.expand_head env t).desc with - | Tconstr (path, _, _) when Path.same path Predef.path_string -> - Some StringType - | Tconstr (path, _, _) - when Path.same path Predef.path_int || Path.same path Predef.path_float -> - Some NumberType - | Tconstr (path, _, _) when Path.same path Predef.path_bigint -> - Some BigintType - | Tconstr (path, _, _) when Path.same path Predef.path_bool -> - Some BooleanType - | Tconstr (path, _, _) when Path.same path Predef.path_dict -> - Some ObjectType - | Tconstr (path, _, _) when Path.same path Predef.path_array -> - Some (InstanceType Array) - | Tconstr (path, _, _) when Path.same path Predef.path_promise -> - Some (InstanceType (Class {name = "Promise"; ancestors = []})) | Ttuple _ -> Some (InstanceType Array) | Tarrow _ -> Some FunctionType | _ -> None) diff --git a/tests/build_tests/super_errors/expected/runtime_annotation_contradicts_builtin.res.expected b/tests/build_tests/super_errors/expected/runtime_annotation_contradicts_builtin.res.expected new file mode 100644 index 0000000000..3473490b2e --- /dev/null +++ b/tests/build_tests/super_errors/expected/runtime_annotation_contradicts_builtin.res.expected @@ -0,0 +1,8 @@ + + We've found a bug for you! + /.../fixtures/runtime_annotation_contradicts_builtin.res:1:19-30 + + 1 │ @typeOf("string") type t = int + 2 │ + + This annotation, @typeOf("string"), contradicts the abbreviated type, whose values are recognized by @typeOf("number"). \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/runtime_annotation_contradicts_manifest.res.expected b/tests/build_tests/super_errors/expected/runtime_annotation_contradicts_manifest.res.expected index fcc9121b91..b0de7da319 100644 --- a/tests/build_tests/super_errors/expected/runtime_annotation_contradicts_manifest.res.expected +++ b/tests/build_tests/super_errors/expected/runtime_annotation_contradicts_manifest.res.expected @@ -6,4 +6,4 @@ 2 │ @typeOf("number") type t = sym 3 │ - This annotation, @typeOf("number"), contradicts the abbreviated type's annotation, @typeOf("symbol"). \ No newline at end of file + This annotation, @typeOf("number"), contradicts the abbreviated type, whose values are recognized by @typeOf("symbol"). \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/runtime_annotation_contradicts_builtin.res b/tests/build_tests/super_errors/fixtures/runtime_annotation_contradicts_builtin.res new file mode 100644 index 0000000000..b3e518808c --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/runtime_annotation_contradicts_builtin.res @@ -0,0 +1 @@ +@typeOf("string") type t = int diff --git a/tests/tests/src/untagged_builtin_alias_test.mjs b/tests/tests/src/untagged_builtin_alias_test.mjs index 8346c5a56a..686d8700f0 100644 --- a/tests/tests/src/untagged_builtin_alias_test.mjs +++ b/tests/tests/src/untagged_builtin_alias_test.mjs @@ -13,17 +13,53 @@ function kind(value) { } } +function make(x) { + return x; +} + +let Score = { + make: make +}; + +function countedKind(value) { + if (typeof value === "number") { + return "number"; + } else { + return value; + } +} + +function scoredKind(value) { + if (typeof value === "number") { + return "number"; + } else { + return value; + } +} + Mocha.describe("Untagged_builtin_alias_test", () => { Mocha.test("aliases of builtin types", () => { - Test_utils.eq("File \"untagged_builtin_alias_test.res\", line 21, characters 7-14", "entries", kind({ + Test_utils.eq("File \"untagged_builtin_alias_test.res\", line 51, characters 7-14", "entries", kind({ a: 1 })); - Test_utils.eq("File \"untagged_builtin_alias_test.res\", line 22, characters 7-14", "text", "text"); - Test_utils.eq("File \"untagged_builtin_alias_test.res\", line 23, characters 7-14", "pair", "pair"); + Test_utils.eq("File \"untagged_builtin_alias_test.res\", line 52, characters 7-14", "text", "text"); + Test_utils.eq("File \"untagged_builtin_alias_test.res\", line 53, characters 7-14", "pair", "pair"); + }); + Mocha.test("annotations stating a builtin type's kind", () => { + Test_utils.eq("File \"untagged_builtin_alias_test.res\", line 57, characters 7-14", "number", "number"); + Test_utils.eq("File \"untagged_builtin_alias_test.res\", line 58, characters 7-14", "name", "name"); + Test_utils.eq("File \"untagged_builtin_alias_test.res\", line 59, characters 7-14", "number", "number"); + Test_utils.eq("File \"untagged_builtin_alias_test.res\", line 60, characters 7-14", "name", "name"); }); }); +let Score$make = make; + export { kind, + Score, + countedKind, + scoredKind, + Score$make, } /* Not a pure module */ diff --git a/tests/tests/src/untagged_builtin_alias_test.res b/tests/tests/src/untagged_builtin_alias_test.res index d5de5e80ee..3548fac296 100644 --- a/tests/tests/src/untagged_builtin_alias_test.res +++ b/tests/tests/src/untagged_builtin_alias_test.res @@ -16,10 +16,47 @@ let kind = value => | Pair(_) => "pair" } +// An annotation can restate what a builtin type is recognized by, and an +// interface can state it over a builtin implementation +@typeOf("number") type count = int + +module Score: { + @typeOf("number") type t + let make: int => t +} = { + type t = int + let make = x => x +} + +@unboxed +type counted = Count(count) | CountName(string) + +let countedKind = value => + switch value { + | Count(_) => "number" + | CountName(name) => name + } + +@unboxed +type scored = Score(Score.t) | ScoreName(string) + +let scoredKind = value => + switch value { + | Score(_) => "number" + | ScoreName(name) => name + } + describe(__MODULE__, () => { test("aliases of builtin types", () => { eq(__LOC__, "entries", kind(Entries(dict{"a": 1}))) eq(__LOC__, "text", kind(Label("text"))) eq(__LOC__, "pair", kind(Pair((1, 2)))) }) + + test("annotations stating a builtin type's kind", () => { + eq(__LOC__, "number", countedKind(Count(1))) + eq(__LOC__, "name", countedKind(CountName("name"))) + eq(__LOC__, "number", scoredKind(Score(Score.make(2)))) + eq(__LOC__, "name", scoredKind(ScoreName("name"))) + }) }) From 59ec47762ab899aec1b3750bd3eeb9d70926f508 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 24 Oct 2026 10:40:47 +0000 Subject: [PATCH 02/13] Resolve the literal of a constructor without @as once Why: "A constructor without @as is its name" was re-derived wherever a tag was read: in the matching facts, constant folding, code generation, the duplicate-literal check, coercions and gentype, each with its own `None` case, and `[]` special-cased in several of them. The layout stores every constructor's literal, the name when there is no `@as` and `0` for `[]`. Readers take it as is, and matching compares tags without the widening to an optional literal. Messages that name the declared `@as` read the constructor's annotation. Since the literal is what the value is, `A` and `@as("A") A` now agree across an interface and in a coercion, and constant folding compares any two constructors by their runtime values. Representation modified (constructor tag in the layout): Example: type t = A | @as("b") B Before (layout): A -> {name: "A", literal: None} B -> {name: "B", literal: Some (String "b")} After (layout): A -> {name: "A", literal: String "A"} B -> {name: "B", literal: String "b"} Review: Does this change generated JavaScript? No snapshot changed: the resolved literal is the value every reader computed before. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- compiler/core/js_dump.ml | 8 +--- compiler/core/lam_compile.ml | 29 +++++------- compiler/core/lam_compile_const.ml | 7 +-- .../gentype/translate_type_declarations.ml | 33 +++++++------- compiler/ml/UntaggedVariants.md | 9 ++-- compiler/ml/ast_untagged_variants.ml | 26 ++++++----- compiler/ml/ctype.ml | 10 ++--- compiler/ml/error_message_utils.ml | 5 +-- compiler/ml/lambda.ml | 44 ++++++++----------- compiler/ml/matching.ml | 4 +- compiler/ml/printtyp.ml | 4 +- compiler/ml/typeopt.ml | 2 +- compiler/ml/variant_coercion.ml | 25 +++++------ compiler/ml/variant_layout.ml | 2 +- compiler/ml/variant_runtime.ml | 30 ++++--------- compiler/ml/variant_runtime.mli | 18 +++----- .../ounit_lambda_constant_tests.ml | 34 +++++++++++--- tests/tests/src/as_constructor_name_test.mjs | 21 +++++++++ tests/tests/src/as_constructor_name_test.res | 28 ++++++++++++ 19 files changed, 182 insertions(+), 157 deletions(-) create mode 100644 tests/tests/src/as_constructor_name_test.mjs create mode 100644 tests/tests/src/as_constructor_name_test.res diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index 80b09fb772..fcacce78a3 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -897,9 +897,7 @@ and expression_desc cxt ~(level : int) f x : cxt = | Tagged {tag; tag_name} -> ( Js_op.Lit (Option.value tag_name ~default:L.tag), (* TAG:xx for inline records *) - match tag.literal with - | None -> E.str p.name - | Some t -> E.literal_tag t ) + E.literal_tag tag.literal ) :: tails in expression_desc cxt ~level f (Object (E.object_entries objs)) @@ -936,9 +934,7 @@ and expression_desc cxt ~(level : int) f x : cxt = else ( Js_op.Lit tag_name, (* TAG:xx *) - match literal with - | None -> E.str p.name - | Some t -> E.literal_tag t ) + E.literal_tag literal ) :: tails in expression_desc cxt ~level f (J.Object (E.object_entries objs)) diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index 678f318e35..d7685a8f96 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -177,14 +177,13 @@ let default_action ~saturated failaction = | None -> Complete | Some x -> if saturated then Complete else Default x -let tag_of_switch_key = function +let tag_of_switch_key : _ -> Variant_runtime.tag_type option = function | Lambda.Switch_int _ -> None - | Switch_constructor (Constant tag) -> - Some (Variant_runtime.to_matchable_tag tag) - | Switch_constructor (Block (Untagged {tag = {name}; block_type})) -> - Some {name; tag_type = Some (Payload_shape block_type)} - | Switch_constructor (Block (Tagged {tag})) -> - Some (Variant_runtime.to_matchable_tag tag) + | Switch_constructor (Constant {literal} | Block (Tagged {tag = {literal}})) + -> + Some (Literal literal) + | Switch_constructor (Block (Untagged {block_type})) -> + Some (Payload_shape block_type) let dispatch_info = function | Lambda.Switch_direct -> (Js_dump_lit.tag, [], []) @@ -696,10 +695,8 @@ let compile output_prefix = List.fold_right (fun (key, lam) acc -> match (tag_of_switch_key key, acc) with - | Some {Variant_runtime.tag_type = Some t}, Some string_table -> - Some ((t, lam) :: string_table) - | Some {name; tag_type = None}, Some string_table -> - Some ((Literal (String name), lam) :: string_table) + | Some tag_type, Some string_table -> + Some ((tag_type, lam) :: string_table) | _, _ -> None) table (Some []) and compile_cases ?(untagged = false) ?(null_guard = false) ~cxt @@ -781,9 +778,8 @@ let compile output_prefix = let named = Ext_list.filter_map sw_consts (fun (key, _) -> match tag_of_switch_key key with - | Some {tag_type = Some (Literal literal)} -> Some literal - | Some {name; tag_type = None} -> Some (String name) - | Some {tag_type = Some (Payload_shape _)} | None -> None) + | Some (Literal literal) -> Some literal + | Some (Payload_shape _) | None -> None) in (* A literal reaches the same default through the payload dispatch when no payload arm accepts its kind and no class @@ -791,9 +787,8 @@ let compile output_prefix = let payload_arms = Ext_list.filter_map sw_blocks (fun (key, _) -> match tag_of_switch_key key with - | Some {tag_type = Some (Payload_shape block_type)} -> - Some block_type - | Some {tag_type = Some (Literal _) | None} | None -> + | Some (Payload_shape block_type) -> Some block_type + | Some (Literal _) | None -> (* The blocks of an untagged variant are all untagged *) None) in diff --git a/compiler/core/lam_compile_const.ml b/compiler/core/lam_compile_const.ml index d29e4c095d..ca1f407931 100644 --- a/compiler/core/lam_compile_const.ml +++ b/compiler/core/lam_compile_const.ml @@ -45,11 +45,8 @@ 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; 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 {literal = Some t} -> E.literal_tag t + | Const_constructor {name = "[]"} -> E.int 0l ~comment:"[]" + | Const_constructor {literal} -> E.literal_tag literal | Const_int i -> E.int i | Const_assertfalse -> E.int 0l ~comment:"assert_false" | Const_char i -> Js_of_lam_string.const_char i diff --git a/compiler/gentype/translate_type_declarations.ml b/compiler/gentype/translate_type_declarations.ml index 08a8293a62..de9efa656d 100644 --- a/compiler/gentype/translate_type_declarations.ml +++ b/compiler/gentype/translate_type_declarations.ml @@ -40,17 +40,15 @@ let create_polyvariant_case (label, attributes) = | _ -> if is_number label then IntLabel label else StringLabel label); } -let create_variant_case label = function - | Some (Variant_runtime.String label) -> +let create_variant_case = function + | Variant_runtime.String label -> {label_js = StringLabel (Emit_text.escape_string_contents label)} - | Some (Variant_runtime.Int label) -> - {label_js = IntLabel (string_of_int label)} - | Some (Variant_runtime.Float label) -> {label_js = FloatLabel label} - | Some (Variant_runtime.BigInt label) -> {label_js = IntLabel label} - | Some (Variant_runtime.Bool label) -> {label_js = BoolLabel label} - | Some Variant_runtime.Null -> {label_js = NullLabel} - | Some Variant_runtime.Undefined -> {label_js = UndefinedLabel} - | None -> {label_js = StringLabel label} + | Variant_runtime.Int label -> {label_js = IntLabel (string_of_int label)} + | Variant_runtime.Float label -> {label_js = FloatLabel label} + | Variant_runtime.BigInt label -> {label_js = IntLabel label} + | Variant_runtime.Bool label -> {label_js = BoolLabel label} + | Variant_runtime.Null -> {label_js = NullLabel} + | Variant_runtime.Undefined -> {label_js = UndefinedLabel} (* The JS name of a declared record field: its runtime name (set by @as), escaped as string contents, or else its identifier with the \"..." of an @@ -255,7 +253,6 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver constructor_declarations |> List.mapi (fun position constructor_declaration -> let constructor_args = constructor_declaration.Types.cd_args in - let name = constructor_declaration.cd_id |> Ident.name in let tag = Variant_runtime.constructor_tag layout position in let args_translation = match constructor_args with @@ -282,25 +279,25 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver |> Translation.translate_dependencies ~config ~output_file_relative ~resolver in - (name, tag, arg_types, import_types)) + (tag, arg_types, import_types)) in let variants_no_payload, variants_with_payload = - variants |> List.partition (fun (_, _, arg_types, _) -> arg_types = []) + variants |> List.partition (fun (_, arg_types, _) -> arg_types = []) in let no_payloads = variants_no_payload - |> List.map (fun (name, tag, _argTypes, _importTypes) -> - create_variant_case name tag) + |> List.map (fun (tag, _argTypes, _importTypes) -> + create_variant_case tag) in let payloads = variants_with_payload - |> List.map (fun (name, tag, arg_types, _importTypes) -> + |> List.map (fun (tag, arg_types, _importTypes) -> let type_ = match arg_types with | [type_] -> type_ | _ -> Tuple arg_types in - {case = create_variant_case name tag; t = type_}) + {case = create_variant_case tag; t = type_}) in let variant_typ = let unboxed = @@ -331,7 +328,7 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver in let import_types = variants - |> List.map (fun (_, _, _, import_types) -> import_types) + |> List.map (fun (_, _, import_types) -> import_types) |> List.concat in {Code_item.export_from_type_declaration; import_types} diff --git a/compiler/ml/UntaggedVariants.md b/compiler/ml/UntaggedVariants.md index c8d495c090..f8598904de 100644 --- a/compiler/ml/UntaggedVariants.md +++ b/compiler/ml/UntaggedVariants.md @@ -66,9 +66,9 @@ a payload and `@tag` on the type do not change the representation. | `@unboxed @tag("kind") type t = TI({x: int}) \| TS(string)` | `TI({x: 1})` | `{x: 1}` | | `@unboxed type t = @as("x") AsX(string) \| AsY(int)` | `AsX("v")` | `"v"` | -- Implementation: `variant_runtime.ml:compute_matching_facts` (a nullary case - without `@as` is its name), `translcore.ml:transl_exp0` (constructor - application). +- Implementation: `ast_untagged_variants.ml:declared_tag` (a case without + `@as` is its name, resolved once in the layout), `translcore.ml:transl_exp0` + (constructor application). - Tests: `spec_test` rule 2. ### 3. `@as` literals @@ -500,7 +500,8 @@ error. An interface and its implementation must agree on `@unboxed`, on `@tag`, on the literal of every nullary case and of every tagged case with a payload, and on the payload kind of every untagged case whose kind the interface -knows. An unknown payload in the interface is its only payload case and is +knows. A case without `@as` has the literal of its name, so `A` and +`@as("A") A` agree, here and in coercions (`as_constructor_name_test.res`). An unknown payload in the interface is its only payload case and is not checked, so it agrees with any payload of the implementation (`untagged_hidden_payload_test.res`). The `@as` of an untagged case with a payload does not change its representation (rule 2) and is not compared. diff --git a/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml index bf6ebd3c41..c707a90cd5 100644 --- a/compiler/ml/ast_untagged_variants.ml +++ b/compiler/ml/ast_untagged_variants.ml @@ -383,7 +383,7 @@ let process_tag_name (attrs : Parsetree.attributes) = !st (* A constructor the compiler generates itself carries no annotations. *) -let generated_tag ~name = {name; literal = None} +let generated_tag ~name = {name; literal = String name} let generated_block_runtime ~name = {tag = generated_tag ~name; tag_name = None} @@ -465,20 +465,17 @@ let check_invariant ~(consts : (Location.t * tag) list) in 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 as literal) -> + | String s -> add_string_literal ~is_const ~loc s + | Int i as literal -> add_nonstring_literal ~is_const ~loc literal (string_of_int i) - | Some (Float f as literal) -> - add_nonstring_literal ~is_const ~loc literal f - | Some (BigInt i as literal) -> + | Float f as literal -> add_nonstring_literal ~is_const ~loc literal f + | BigInt i as literal -> add_nonstring_literal ~is_const ~loc literal (i ^ "n") - | Some (Bool b as literal) -> + | Bool b as literal -> add_nonstring_literal ~is_const ~loc literal (if b then "true" else "false") - | Some (Null as literal) -> - add_nonstring_literal ~is_const ~loc literal "null" - | Some (Undefined as literal) -> + | Null as literal -> add_nonstring_literal ~is_const ~loc literal "null" + | Undefined as literal -> add_nonstring_literal ~is_const ~loc literal "undefined" in @@ -524,8 +521,13 @@ let check_invariant ~(consts : (Location.t * tag) list) | StringType -> incr string_types); invariant loc tag.name) +(* A constructor without [@as] is represented by its name *) +let declared_tag (cstr : Types.constructor_declaration) = + let name = Ident.name cstr.cd_id in + {name; literal = Option.value cstr.cd_runtime_tag ~default:(String name)} + let get_cstr_loc_tag (cstr : Types.constructor_declaration) = - (cstr.cd_loc, {name = Ident.name cstr.cd_id; literal = cstr.cd_runtime_tag}) + (cstr.cd_loc, declared_tag cstr) let check_tag_field_conflicts (cstrs : Types.constructor_declaration list) = List.iter diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index 51d926eaae..4c319279ed 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -3580,7 +3580,7 @@ let rec subtype_rec env trace t1 t2 cstrs = Variant_coercion.can_try_coerce_variant_to_primitive_opt (extract_concrete_typedecl_opt env t2) with - | Some (p, _, _, false) -> + | Some (p, _, false) -> (* Not @unboxed *) ( trace, t1, @@ -3590,7 +3590,7 @@ let rec subtype_rec env trace t1 t2 cstrs = (Coercion_target_variant_not_unboxed {variant_name = p; primitive = path}) ) :: cstrs - | Some (p, constructors, _, true) -> + | Some (p, constructors, true) -> if Variant_coercion.variant_has_case_covering_type constructors ~path_is_same_fn:(fun p -> Path.same p path) @@ -3622,12 +3622,12 @@ let rec subtype_rec env trace t1 t2 cstrs = Variant_coercion.can_try_coerce_variant_to_primitive_opt (extract_concrete_typedecl_opt env t1) with - | Some (p, constructors, layout, unboxed) -> + | Some (p, constructors, unboxed) -> let runtime_representation_issues = constructors |> Variant_coercion .variant_has_same_runtime_representation_as_target - ~target_path:path ~unboxed ~layout + ~target_path:path ~unboxed in if List.length runtime_representation_issues <> 0 then ( trace, @@ -3857,7 +3857,7 @@ let rec subtype_rec env trace t1 t2 cstrs = in match Variant_coercion.can_coerce_polyvariant_to_variant ~row_fields - ~variant_constructors ~layout ~unboxed + ~variant_constructors ~unboxed with | Ok _ -> cstrs | Error _ -> diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index 8665b0c6fb..67031fa22e 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -704,9 +704,8 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf let constructor_name = Ident.name cd.cd_id in let runtime_repr = match Variant_runtime.constructor_tag layout position with - | Some (String s) -> Some s (* @as("string_value") *) - | Some _ -> None (* @as with non-string values *) - | None -> Some constructor_name (* No @as, use constructor name *) + | String s -> Some s + | Int _ | Float _ | BigInt _ | Bool _ | Null | Undefined -> None in match runtime_repr with | Some repr -> Some (repr, constructor_name) diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 9912aade63..b0ef179828 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -422,7 +422,7 @@ let const_constructor (tag : Variant_runtime.tag) = if tag.name = "()" then const_unit else match tag.literal with - | Some (Variant_runtime.Int v) -> Const_int (Int32.of_int v) + | Variant_runtime.Int v when tag.name <> "[]" -> Const_int (Int32.of_int v) | _ -> Const_constructor tag (* A constructor with an optional shape carries no payload when constant. *) @@ -588,7 +588,7 @@ let rec const_some_none_depth (c : structured_constant) : int = if depth < 0 then depth else depth + 1 | Const_module_alias | Const_js_undefined _ (* A constructor represented by [undefined], [@as(undefined)] *) - | Const_constructor {literal = Some Undefined} -> + | Const_constructor {literal = Undefined} -> 0 | _ -> -1 @@ -825,10 +825,8 @@ let runtime_value_kind (c : structured_constant) = | Const_js_null -> Is_literal Null | Const_js_undefined _ -> Is_literal Undefined | Const_polyvar name -> Is_literal (String name) - | Const_constructor {name = "[]"; literal = None} -> Is_literal (Int 0) - | Const_constructor {name; literal = None} -> Is_literal (String name) - | Const_constructor {literal = Some (BigInt _)} -> Unknown_value - | Const_constructor {literal = Some literal} -> Is_literal literal + | Const_constructor {literal = BigInt _} -> Unknown_value + | Const_constructor {literal} -> Is_literal literal | Const_block (Blk_tuple, _) -> Is_array | Const_block (Blk_record {fields}, _) -> if record_fields_are_array fields then Is_array else Is_object @@ -887,11 +885,6 @@ let switch lam (lam_switch : lambda_switch) : t = | Switch_constructor case when matches case -> Some action | Switch_int _ | Switch_constructor _ -> None)) in - let literal_of_tag (tag : Variant_runtime.tag) = - match tag.literal with - | Some literal -> literal - | None -> Variant_runtime.String tag.name - in let matches_block = value_has_block_type ~block_types:facts.block_types in let kind = runtime_value_kind cst in match kind with @@ -900,7 +893,7 @@ let switch lam (lam_switch : lambda_switch) : t = when Ext_list.exists facts.literal_tags (literal_denotes_same literal) -> (* The literal side wins, exactly as it does at runtime. *) find_in lam_switch.sw_consts (function - | Constant tag -> literal_denotes_same literal (literal_of_tag tag) + | Constant tag -> literal_denotes_same literal tag.literal | Block _ -> false) | Is_literal _ | Is_object | Is_array -> (* Not a declared literal, so the payload's runtime shape decides. *) @@ -932,8 +925,7 @@ let switch lam (lam_switch : lambda_switch) : t = Ext_list.find_opt lam_switch.sw_consts (fun (key, action) -> match key with | Switch_int ordinal when ordinal = i -> Some action - | Switch_constructor - (Constant {literal = Some (Variant_runtime.Int value)}) + | Switch_constructor (Constant {literal = Variant_runtime.Int value}) when value = i -> Some action | Switch_int _ | Switch_constructor _ -> None) @@ -1015,13 +1007,14 @@ let prim ~primitive:(prim : primitive) ~args loc : t = | Cneq -> a <> b | _ -> assert false) | ( Pintcomp ((Ceq | Cneq) as op), - Const_constructor {name = a; literal = None}, - Const_constructor {name = b; literal = None} ) -> - (* Both runtime representations are the constructor names *) + Const_constructor {literal = a}, + Const_constructor {literal = b} ) -> + (* Constants are compared by their runtime values *) + let same = Variant_runtime.same_literal_value a b in Lift.bool (match op with - | Ceq -> a = b - | Cneq -> a <> b + | Ceq -> same + | Cneq -> not same | _ -> assert false) | ( ( Paddint | Psubint | Pmulint | Pdivint | Pmodint | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint ), @@ -1172,15 +1165,14 @@ 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; literal} -> ( + | Const_constructor {literal} -> ( (* Truthiness of the canonical runtime representation *) 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 | Undefined) -> Some false - | Some (Float _ | BigInt _) -> None) + | String s -> Some (s <> "") + | Int i -> Some (i <> 0) + | Bool b -> Some b + | Null | Undefined -> Some false + | Float _ | BigInt _ -> None) let if_ (a : t) (b : t) (c : t) : t = match a with diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index d768ff18db..bd469b6c93 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -1455,7 +1455,7 @@ let rec rejects_nested_some p = | Ordinary_constructor representation when not (Datarepr.constructor_has_optional_shape cstr) -> ( match Variant_runtime.representation representation with - | Constant {literal} -> literal <> Some Variant_runtime.Undefined + | Constant {literal} -> literal <> Variant_runtime.Undefined | Block (Untagged {block_type = ObjectType | UnknownType}) -> false | Block (Untagged _) -> true | Block (Tagged _) -> false) @@ -2293,7 +2293,7 @@ and switch_defaults_on_undefined (sw : lambda_switch) = && List.for_all (function | Switch_constructor (Constant {literal}), _ -> - literal <> Some Variant_runtime.Undefined + literal <> Variant_runtime.Undefined | _ -> true) sw.sw_consts | Switch_direct -> false diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index 85e05d4677..3963d5cf9a 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -930,9 +930,7 @@ and tree_of_constructor ?printing_context ~layout ~position cd = | Bool b -> Printf.sprintf "@as(%b)" b | BigInt s -> Printf.sprintf "@as(%sn)" s in - match Variant_runtime.constructor_tag layout position with - | Some d -> Some (as_annotation d) - | None -> None + Option.map as_annotation cd.cd_runtime_tag in let arg () = tree_of_constructor_arguments ?printing_context cd.cd_args in match cd.cd_res with diff --git a/compiler/ml/typeopt.ml b/compiler/ml/typeopt.ml index fce5edc493..4ad9213b73 100644 --- a/compiler/ml/typeopt.ml +++ b/compiler/ml/typeopt.ml @@ -100,7 +100,7 @@ let rec cannot_contain_undefined ~visiting (typ : Types.type_expr) (env : Env.t) | Variant_runtime.Block (Tagged {tag}) -> (tag, false) | Variant_runtime.Block (Untagged {tag}) -> (tag, true) in - tag.literal <> Some Variant_runtime.Undefined + tag.literal <> Variant_runtime.Undefined && ((not payload_is_unboxed) || match cd.cd_args with diff --git a/compiler/ml/variant_coercion.ml b/compiler/ml/variant_coercion.ml index cac2b9b44d..11e90a6e71 100644 --- a/compiler/ml/variant_coercion.ml +++ b/compiler/ml/variant_coercion.ml @@ -42,12 +42,12 @@ let variant_has_case_covering_type (* Checks if every case of the variant has the same runtime representation as the target type. *) let variant_has_same_runtime_representation_as_target ~(target_path : Path.t) - ~unboxed ~layout (constructors : Types.constructor_declaration list) = + ~unboxed (constructors : Types.constructor_declaration list) = (* Helper function to check if a constructor has the same runtime representation as the target type *) - let has_same_runtime_representation position - (c : Types.constructor_declaration) = + let has_same_runtime_representation (c : Types.constructor_declaration) = let args = c.cd_args in - let as_payload = Variant_runtime.constructor_tag layout position in + (* The messages name the declared [@as] *) + let as_payload = c.cd_runtime_tag in match args with | Cstr_tuple [{desc = Tconstr (p, [], _)}] when unboxed -> @@ -112,8 +112,7 @@ let variant_has_same_runtime_representation_as_target ~(target_path : Path.t) (Inline_record_cannot_be_coerced {constructor_name = Ident.name c.cd_id}) in - List.mapi has_same_runtime_representation constructors - |> List.filter_map Fun.id + List.filter_map has_same_runtime_representation constructors let can_try_coerce_variant_to_primitive ((_, p, typedecl) : Path.t * Path.t * Types.type_declaration) = @@ -130,7 +129,6 @@ let can_try_coerce_variant_to_primitive Some ( p, constructors, - layout, type_representation = Unboxed || (Variant_runtime.configuration layout).unboxed ) | _ -> None @@ -141,10 +139,7 @@ let can_try_coerce_variant_to_primitive_opt p = | Some p -> can_try_coerce_variant_to_primitive p let variant_representation_matches tag1 tag2 = - match (tag1, tag2) with - | None, None -> true - | Some s1, Some s2 when s1 = s2 -> true - | _ -> false + Variant_runtime.same_literal_value tag1 tag2 type variant_configuration_error = | Untagged of {left_is_unboxed: bool} @@ -230,8 +225,8 @@ let variant_configuration_can_be_coerced_raises ~is_spread_context ~left_loc error = TagName {left_tag; right_tag}; })) -let can_coerce_polyvariant_to_variant ~row_fields ~variant_constructors ~layout - ~unboxed = +let can_coerce_polyvariant_to_variant ~row_fields ~variant_constructors ~unboxed + = let polyvariant_runtime_representations = row_fields |> List.filter_map (fun (label, (field : Types.row_field)) -> @@ -248,9 +243,9 @@ let can_coerce_polyvariant_to_variant ~row_fields ~variant_constructors ~layout List.for_all (fun polyvariant_value -> variant_constructors - |> List.mapi (fun position (c : Types.constructor_declaration) -> + |> List.map (fun (c : Types.constructor_declaration) -> let constructor_name = Ident.name c.cd_id in - match Variant_runtime.constructor_tag layout position with + match c.cd_runtime_tag with | Some (String as_runtime_string) -> (* `@as("")`, does the configured string match the polyvariant value? *) as_runtime_string = polyvariant_value diff --git a/compiler/ml/variant_layout.ml b/compiler/ml/variant_layout.ml index 449c7b73ac..6bb51e8729 100644 --- a/compiler/ml/variant_layout.ml +++ b/compiler/ml/variant_layout.ml @@ -191,7 +191,7 @@ let get_block_type ~env (cstr : Types.constructor_declaration) : block_type = let layout_from_type_variant ~(configuration : configuration) ~env (cstrs : Types.constructor_declaration list) : Variant_runtime.layout = let get_block (cstr : Types.constructor_declaration) : block = - let tag = {name = Ident.name cstr.cd_id; literal = cstr.cd_runtime_tag} in + let tag = declared_tag cstr in let tag_name = process_tag_name cstr.cd_attributes in if configuration.unboxed then Untagged {tag; block_type = get_block_type ~env cstr} diff --git a/compiler/ml/variant_runtime.ml b/compiler/ml/variant_runtime.ml index 4b21e9294d..2c04022f55 100644 --- a/compiler/ml/variant_runtime.ml +++ b/compiler/ml/variant_runtime.ml @@ -110,12 +110,9 @@ let literal_passes (literal : literal_tag) (block_type : block_type) = value represented directly by its payload. *) type tag_type = Literal of literal_tag | Payload_shape 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 tag = {name: string; literal: literal_tag} +(** A constructor's name and its runtime literal: what [@as] states, or the + name itself *) type tagged_block = {tag: tag; tag_name: string option} @@ -125,11 +122,6 @@ type block = | Tagged of tagged_block | Untagged of {tag: tag; block_type: block_type} -(* 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} @@ -216,14 +208,7 @@ let compute_matching_facts ~tag_name (constructors : constructor_case array) : let literal_tags = ref [] in Array.iter (function - | 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 := literal :: !literal_tags + | Constant {literal} -> literal_tags := literal :: !literal_tags | Block (Untagged {block_type}) -> block_types := block_type :: !block_types | Block (Tagged _) -> ()) @@ -260,9 +245,10 @@ let complete_layout layout_ref layout = predefined types, whose declarations are built by hand *) let plain_layout (cases : (string * bool (* has payload *)) list) : layout_ref = let case (name, has_payload) = - if has_payload then - Block (Tagged {tag = {name; literal = None}; tag_name = None}) - else Constant {name; literal = None} + (* The empty list is the number 0 *) + let literal = if name = "[]" then Int 0 else String name in + if has_payload then Block (Tagged {tag = {name; literal}; tag_name = None}) + else Constant {name; literal} in ref (Complete diff --git a/compiler/ml/variant_runtime.mli b/compiler/ml/variant_runtime.mli index 81a6153c94..1d57cd6fa0 100644 --- a/compiler/ml/variant_runtime.mli +++ b/compiler/ml/variant_runtime.mli @@ -71,12 +71,9 @@ val literal_passes : literal_tag -> block_type -> bool value represented directly by its payload. *) type tag_type = Literal of literal_tag | Payload_shape 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 tag = {name: string; literal: literal_tag} +(** A constructor's name and its runtime literal: what [@as] states, or the + name itself *) type tagged_block = {tag: tag; tag_name: string option} @@ -88,10 +85,6 @@ type block = 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 @@ -121,7 +114,10 @@ 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 -> literal_tag option + +val constructor_tag : layout -> int -> literal_tag +(** The literal of a constant constructor, or of the tag of a tagged one *) + val representation : constructor_reference -> constructor_case val length : layout -> int val num_constants : layout -> int diff --git a/tests/ounit_tests/ounit_lambda_constant_tests.ml b/tests/ounit_tests/ounit_lambda_constant_tests.ml index 5fa2219cc5..8b674b5cba 100644 --- a/tests/ounit_tests/ounit_lambda_constant_tests.ml +++ b/tests/ounit_tests/ounit_lambda_constant_tests.ml @@ -3,16 +3,16 @@ open OUnit let ( =~ ) = OUnit.assert_equal let runtime name : Variant_runtime.tagged_block = - {tag = {name; literal = None}; tag_name = None} + {tag = {name; literal = String name}; tag_name = None} let constructor name = Lambda.Blk_constructor {name; num_nonconst = 1; runtime = runtime name} let literal name value : Variant_runtime.constructor_case = - Constant {name; literal = Some value} + Constant {name; literal = value} let block name shape : Variant_runtime.constructor_case = - Block (Untagged {tag = {name; literal = None}; block_type = shape}) + Block (Untagged {tag = {name; literal = String name}; block_type = shape}) let action s = Lambda.const (Const_string s) @@ -82,7 +82,7 @@ let switch_tests = assert_fold color_switch (Const_string "primary") "literal"; assert_fold color_switch (Const_string "blue") "payload"; assert_fold color_switch - (Const_constructor {name = "Alias"; literal = Some (String "primary")}) + (Const_constructor {name = "Alias"; literal = String "primary"}) "literal" ); ( "declaration literals missing from match select default" >:: fun _ -> let sw = @@ -156,7 +156,8 @@ let switch_tests = ~cases:[(zero, "zero"); (values, "values")] ~default:None in - assert_fold sw (Const_constructor {name = "[]"; literal = None}) "zero" ); + assert_fold sw (Const_constructor {name = "[]"; literal = Int 0}) "zero" + ); ( "unknown values do not select default" >:: fun _ -> let one = literal "One" (BigInt "1") in let value = block "Value" UnknownType in @@ -168,7 +169,7 @@ let switch_tests = List.iter (assert_deferred sw) [ Const_bigint (false, "1"); - Const_constructor {name = "DecimalTen"; literal = Some (BigInt "1_0")}; + Const_constructor {name = "DecimalTen"; literal = BigInt "1_0"}; Const_char 65; Const_some (Const_int 1l); ] ); @@ -200,6 +201,27 @@ let suites = __FILE__ >::: switch_tests @ [ + ( "constant constructors compare by runtime value" >:: fun _ -> + let compare op a b = + Lambda.prim ~primitive:(Pintcomp op) + ~args:[Lambda.const a; Lambda.const b] + Location.none + in + let named = + Lambda.Const_constructor {name = "A"; literal = String "A"} + and declared = + Lambda.Const_constructor {name = "B"; literal = String "A"} + and other = + Lambda.Const_constructor {name = "C"; literal = String "C"} + and number = + Lambda.Const_constructor {name = "D"; literal = Float "1.0"} + and same_number = + Lambda.Const_constructor {name = "E"; literal = Float "1"} + in + Lambda.const Const_js_true =~ compare Ceq named declared; + Lambda.const Const_js_false =~ compare Ceq named other; + Lambda.const Const_js_true =~ compare Cneq named other; + Lambda.const Const_js_true =~ compare Ceq number same_number ); ( "integer pattern constants agree with Lambda" >:: fun _ -> List.iter (fun (literal, expected) -> diff --git a/tests/tests/src/as_constructor_name_test.mjs b/tests/tests/src/as_constructor_name_test.mjs new file mode 100644 index 0000000000..6800be087e --- /dev/null +++ b/tests/tests/src/as_constructor_name_test.mjs @@ -0,0 +1,21 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + +import * as Mocha from "mocha"; +import * as Test_utils from "./test_utils.mjs"; + +let Stated = { + a: "A" +}; + +Mocha.describe("As_constructor_name_test", () => { + Mocha.test("coercion", () => Test_utils.eq("File \"as_constructor_name_test.res\", line 22, characters 7-14", "A", "A")); + Mocha.test("interface", () => Test_utils.eq("File \"as_constructor_name_test.res\", line 26, characters 7-14", "A", "A")); +}); + +let declaredA = "A"; + +export { + declaredA, + Stated, +} +/* Not a pure module */ diff --git a/tests/tests/src/as_constructor_name_test.res b/tests/tests/src/as_constructor_name_test.res new file mode 100644 index 0000000000..678c15d0ba --- /dev/null +++ b/tests/tests/src/as_constructor_name_test.res @@ -0,0 +1,28 @@ +open Mocha +open Test_utils + +// A constructor without @as is represented by its name, so `@as("A")` on a +// constructor named A states the same representation + +type named = A | B +type declared = | @as("A") A | B | C + +let declaredA = (A: named :> declared) + +module Stated: { + type t = A | B + let a: t +} = { + type t = | @as("A") A | B + let a = A +} + +describe(__MODULE__, () => { + test("coercion", () => { + eq(__LOC__, declaredA, A) + }) + + test("interface", () => { + eq(__LOC__, Stated.a, Stated.A) + }) +}) From c3c1c9dbcfe8e305d3f98b9eba2722ef852c428e Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 24 Oct 2026 10:46:32 +0000 Subject: [PATCH 03/13] Allow @notUndefined on type abbreviations Why: `@instanceOf` and `@typeOf` can refine or restate the type an abbreviation stands for, while `@notUndefined` was rejected on every abbreviation, even of an abstract type it could refine. `@notUndefined` on an abbreviation follows the rule of the other annotations: it can refine a type whose representation the compiler does not see, or restate that the type cannot be undefined, keeping a payload kind the type has. The check whether a type can be undefined is shared with interface inclusion (`Typeopt.undefinedness`); `get_unboxed_type_representation` moves to `Ctype` so that `Typedecl` can call it. Diagnostic modified (@notUndefined on an abbreviation): Example: @notUndefined type t = option Before (diagnostic): @notUndefined can only be used on abstract types After (diagnostic): @notUndefined on a type abbreviation must describe an abstract type, or a type with the same annotation. The abbreviated type already has a runtime representation the compiler knows, or can be undefined. Diagnostic modified (@notUndefined on a record): Example: @notUndefined type t = {x: int} Before (diagnostic): @notUndefined can only be used on abstract types After (diagnostic): @notUndefined can only be used on abstract types and type abbreviations, whose runtime representation it describes. JS modified (refined abstract type): Example: type opaque @notUndefined type refined = opaque let wrap = (x: refined) => Some(x) Before (js): error After (js): function wrap(x) { return x; } Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- changes/untagged-declarations.polish.md | 1 + compiler/ml/UntaggedVariants.md | 28 +++++-- compiler/ml/ctype.ml | 32 ++++++++ compiler/ml/ctype.mli | 4 + compiler/ml/includemod.ml | 24 ++---- compiler/ml/typedecl.ml | 80 +++++++------------ compiler/ml/typedecl.mli | 1 - compiler/ml/typeopt.ml | 24 +++++- compiler/ml/typeopt.mli | 11 +++ compiler/ml/variant_layout.ml | 9 ++- .../not_undefined_attribute/demo.res | 2 +- .../not_undefined_attribute/input.js | 8 +- ...valid_attribute_not_undefined.res.expected | 6 +- ...ned_on_functor_parameter_type.res.expected | 11 +++ .../not_undefined_on_option.res.expected | 8 ++ .../invalid_attribute_not_undefined.res | 2 +- ...ot_undefined_on_functor_parameter_type.res | 7 ++ .../fixtures/not_undefined_on_option.res | 1 + tests/tests/src/as_constructor_name_test.res | 2 +- .../src/not_undefined_abbreviation_test.mjs | 46 +++++++++++ .../src/not_undefined_abbreviation_test.res | 41 ++++++++++ 21 files changed, 261 insertions(+), 87 deletions(-) create mode 100644 changes/untagged-declarations.polish.md create mode 100644 tests/build_tests/super_errors/expected/not_undefined_on_functor_parameter_type.res.expected create mode 100644 tests/build_tests/super_errors/expected/not_undefined_on_option.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/not_undefined_on_functor_parameter_type.res create mode 100644 tests/build_tests/super_errors/fixtures/not_undefined_on_option.res create mode 100644 tests/tests/src/not_undefined_abbreviation_test.mjs create mode 100644 tests/tests/src/not_undefined_abbreviation_test.res diff --git a/changes/untagged-declarations.polish.md b/changes/untagged-declarations.polish.md new file mode 100644 index 0000000000..e95fa333b6 --- /dev/null +++ b/changes/untagged-declarations.polish.md @@ -0,0 +1 @@ +- Allow `@notUndefined` on type abbreviations, and `@typeOf` restating a builtin type's kind, as in `@typeOf("number") type count = int`; a constructor `A` and `@as("A") A` now agree across interfaces and coercions. diff --git a/compiler/ml/UntaggedVariants.md b/compiler/ml/UntaggedVariants.md index f8598904de..d28c056209 100644 --- a/compiler/ml/UntaggedVariants.md +++ b/compiler/ml/UntaggedVariants.md @@ -460,12 +460,22 @@ hold `undefined`. ### 13. `@notUndefined` -`@notUndefined` on an abstract type without a manifest declares that its -values are never `undefined`. It affects only rule 12: `option` of the type, -and of an untagged variant with a payload of the type, is unboxed. It does not -make the type a recognized payload kind (rule 4). On any other type -declaration it is an error, "@notUndefined can only be used on abstract -types". `@instanceOf` and `@typeOf` (rule 5) imply it. +`@notUndefined` on an abstract type declares that its values are never +`undefined`. It affects only rule 12: `option` of the type, and of an +untagged variant with a payload of the type, is unboxed. It does not make the +type a recognized payload kind (rule 4). `@instanceOf` and `@typeOf` (rule 5) +imply it. + +On an abbreviation it follows the rule of rule 5: it can refine a type whose +representation the compiler does not see, such as an abstract type, or +restate that the abbreviated type cannot be `undefined`, as +`@notUndefined type count = int` does, which keeps the kind of `int`. + +| Declaration | Error | Fixture | +| --- | --- | --- | +| `@notUndefined type t = {x: int}`, or on a variant | @notUndefined can only be used on abstract types and type abbreviations, ... | `invalid_attribute_not_undefined.res` | +| `@notUndefined type t = option` | @notUndefined on a type abbreviation must describe an abstract type, ... | `not_undefined_on_option.res`, `tests/build_tests/not_undefined_attribute` | +| `@notUndefined type t = X.t` in a functor of `X` | @notUndefined cannot describe the type of a functor parameter, ... | `not_undefined_on_functor_parameter_type.res` | When an interface declares a type `@notUndefined`, its implementation must be a type that cannot hold `undefined` either, or a type whose representation @@ -478,14 +488,16 @@ differ: the second declaration is @notUndefined, but the first declaration can hold undefined". The same holds for functor arguments and `with type` constraints. -- Implementation: `typedecl.ml:transl_declaration`; +- Implementation: `typedecl.ml:transl_declaration`, + `check_not_undefined_manifest`; `typeopt.ml:undefinedness`; `ast_untagged_variants.ml:has_not_undefined`; `variant_layout.ml:declaration_shape`; `typeopt.ml:type_cannot_contain_undefined`; `includemod.ml:not_undefined_mismatch`. - Tests: `spec_test` rule 13; fixtures `invalid_attribute_not_undefined.res`, `not_undefined_functor_argument.res`, `not_undefined_functor_parameter.res`; - `tests/tests/src/not_undefined_interface_test.res`; + `tests/tests/src/not_undefined_interface_test.res`, + `not_undefined_abbreviation_test.res`; `tests/build_tests/super_errors_multi/fixtures/Cross_not_undefined_option_implementation`; `tests/build_tests/not_undefined_attribute`. - Shaped by #7458, #7464, #8964. diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index 4c319279ed..b1326f398a 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -4391,3 +4391,35 @@ let get_arity env typ = module For_test = struct let previous_env_is_empty () = !(previous_env ()) == Env.empty end + +(* We use the expand_head_opt version of expand_head to get access + to the manifest type of private abbreviations. *) +let rec get_unboxed_type_representation env ty fuel = + if fuel < 0 then None + else + let ty = repr (expand_head_opt env ty) in + match ty.desc with + | Tconstr (p, args, _) -> ( + match Env.find_type p env with + | exception Not_found -> Some ty + | {type_representation = Boxed} -> Some ty + | { + type_params; + type_kind = + ( Type_record ([{ld_type = ty2; _}], _) + | Type_variant ([{cd_args = Cstr_tuple [ty2]; _}], _) + | Type_variant ([{cd_args = Cstr_record [{ld_type = ty2; _}]; _}], _) ); + } -> + get_unboxed_type_representation env + (apply env type_params ty2 args) + (fuel - 1) + | {type_kind = Type_abstract} -> + None + (* This case can occur when checking a recursive unboxed type + declaration. *) + | _ -> assert false (* only the above can be unboxed *)) + | _ -> Some ty + +let get_unboxed_type_representation env ty = + (* Do not give too much fuel: PR#7424 *) + get_unboxed_type_representation env ty 100 diff --git a/compiler/ml/ctype.mli b/compiler/ml/ctype.mli index 2b3087037f..09bea4bbb9 100644 --- a/compiler/ml/ctype.mli +++ b/compiler/ml/ctype.mli @@ -347,3 +347,7 @@ module For_test : sig (** The environment of the last expansion on this domain is still the initial empty one. *) end + +val get_unboxed_type_representation : Env.t -> type_expr -> type_expr option +(** The type an [@unboxed] wrapper is represented by, through any number of + wrappers *) diff --git a/compiler/ml/includemod.ml b/compiler/ml/includemod.ml index 08f44bbe4a..fbd64367ad 100644 --- a/compiler/ml/includemod.ml +++ b/compiler/ml/includemod.ml @@ -63,31 +63,21 @@ let value_descriptions ~loc env cxt subst id vd1 vd2 = (* Inclusion between type declarations *) (* [@notUndefined] lets clients unbox [option] of the type, so the - implementation must be a type that cannot hold [undefined] either. A type - whose representation the compiler does not see, an abstract type (also - through an abbreviation) or a JavaScript object type, has none that - contradicts it. A functor parameter's or a locally abstract type stands - for any type, so it does not count as abstract. *) + implementation must be a type that cannot hold [undefined] either, or one + whose representation the compiler does not see, which has none that + contradicts it. *) let not_undefined_mismatch env id (decl1 : Types.type_declaration) (decl2 : Types.type_declaration) = match decl2.type_shape with | Unstated | Recognized_as _ -> [] - | Never_undefined -> + | Never_undefined -> ( let env = Env.add_type ~check:false id decl1 env in let ty = Btype.newgenty (Tconstr (Pident id, decl1.type_params, ref Mnil)) in - let opaque = - match (Ctype.expand_head_opt env ty).desc with - | Tconstr (path, _, _) -> ( - match Variant_layout.abstractness ~env path with - | Opaque -> true - | Stands_for_another | Not_abstract -> false) - | Tobject _ -> true - | _ -> false - in - if opaque || Typeopt.type_cannot_contain_undefined ty env then [] - else [Includecore.Not_undefined] + match Typeopt.undefinedness env ty with + | Cannot_be_undefined | Unseen -> [] + | Stands_for_another | Can_be_undefined -> [Includecore.Not_undefined]) let type_declarations ~loc env ?(old_env = env) cxt subst id decl1 decl2 = Env.mark_type_used env (Ident.name id) decl1; diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index d6f78c0c74..aed16933fc 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -48,7 +48,6 @@ type error = | Bad_fixed_type of string | Unbound_type_var_ext of type_expr * extension_constructor | Varying_anonymous - | Invalid_attribute of string | Bad_immediate_attribute | Bad_unboxed_attribute of string | Nonrec_gadt @@ -119,38 +118,6 @@ let update_type temp_env env id loc = try Ctype.unify env (Ctype.newconstr path params) ty with Ctype.Unify trace -> raise (Error (loc, Type_clash (env, trace)))) -(* We use the Ctype.expand_head_opt version of expand_head to get access - to the manifest type of private abbreviations. *) -let rec get_unboxed_type_representation env ty fuel = - if fuel < 0 then None - else - let ty = Ctype.repr (Ctype.expand_head_opt env ty) in - match ty.desc with - | Tconstr (p, args, _) -> ( - match Env.find_type p env with - | exception Not_found -> Some ty - | {type_representation = Boxed} -> Some ty - | { - type_params; - type_kind = - ( Type_record ([{ld_type = ty2; _}], _) - | Type_variant ([{cd_args = Cstr_tuple [ty2]; _}], _) - | Type_variant ([{cd_args = Cstr_record [{ld_type = ty2; _}]; _}], _) ); - } -> - get_unboxed_type_representation env - (Ctype.apply env type_params ty2 args) - (fuel - 1) - | {type_kind = Type_abstract} -> - None - (* This case can occur when checking a recursive unboxed type - declaration. *) - | _ -> assert false (* only the above can be unboxed *)) - | _ -> Some ty - -let get_unboxed_type_representation env ty = - (* Do not give too much fuel: PR#7424 *) - get_unboxed_type_representation env ty 100 - (* Determine if a type definition defines a fixed type. (PW) *) let is_fixed_type sd = let rec has_row_var sty = @@ -369,20 +336,35 @@ let make_constructor env type_path type_params sargs sret_type = any type variable present in [ty]. *) +(* [@notUndefined] on an abbreviation is a claim about the abbreviated type, + as [@instanceOf] and [@typeOf] are: it can refine a type whose + representation the compiler does not see, or restate that a type cannot + hold [undefined] *) +let check_not_undefined_manifest ~loc ~env (decl : Types.type_declaration) = + match decl.type_manifest with + | Some manifest + when Ast_untagged_variants.has_not_undefined decl.type_attributes -> ( + let error err = raise (Ast_untagged_variants.Error (loc, err)) in + match Typeopt.undefinedness env manifest with + | Cannot_be_undefined | Unseen -> () + | Stands_for_another -> + error (RuntimeAnnotationOnTypeParameter "notUndefined") + | Can_be_undefined -> + error (RuntimeAnnotationOnUnrelatedType "notUndefined")) + | Some _ | None -> () + +let check_manifest_annotations ~loc ~env decl = + Variant_layout.check_manifest_annotation ~loc ~env decl; + check_not_undefined_manifest ~loc ~env decl + let transl_declaration ~type_record_as_object env sdecl id = - (* Check for @notUndefined attribute *) - let has_not_undefined = + if Ast_untagged_variants.has_not_undefined sdecl.ptype_attributes - in - (if has_not_undefined then - match (sdecl.ptype_kind, sdecl.ptype_manifest) with - | Ptype_abstract, None -> () - | _ -> - raise - (Error - ( sdecl.ptype_loc, - Invalid_attribute - "@notUndefined can only be used on abstract types" ))); + && sdecl.ptype_kind <> Ptype_abstract + then + raise + (Ast_untagged_variants.Error + (sdecl.ptype_loc, RuntimeAnnotationOnRepresentedType "notUndefined")); Ast_untagged_variants.check_runtime_annotation ~loc:sdecl.ptype_loc ~is_abstract_or_abbreviation:(sdecl.ptype_kind = Ptype_abstract) sdecl.ptype_attributes; @@ -1343,7 +1325,7 @@ let compute_immediacy env tdecl = | Type_variant ([{cd_args = Cstr_record [{ld_type = arg; _}]; _}], _), _ | Type_record ([{ld_type = arg; _}], _), _ when tdecl.type_representation = Unboxed -> ( - match get_unboxed_type_representation env arg with + match Ctype.get_unboxed_type_representation env arg with | Some argrepr -> not (Ctype.maybe_pointer_type env argrepr) | None -> false) | Type_variant ((_ :: _ as cstrs), _), _ -> @@ -1623,8 +1605,7 @@ let transl_type_decl env rec_flag sdecl_list = in List.iter2 (fun sdecl (_, decl) -> - Variant_layout.check_manifest_annotation ~loc:sdecl.ptype_loc ~env:newenv - decl) + check_manifest_annotations ~loc:sdecl.ptype_loc ~env:newenv decl) sdecl_list decls; List.iter2 (check_constraints ~type_record_as_object newenv) sdecl_list decls; (* Name recursion *) @@ -2037,7 +2018,7 @@ let transl_with_constraint env id row_path orig_decl sdecl = let decl = {decl with type_shape = Variant_layout.declaration_shape ~env decl} in - Variant_layout.check_manifest_annotation ~loc:sdecl.ptype_loc ~env decl; + check_manifest_annotations ~loc:sdecl.ptype_loc ~env decl; let decl = name_recursion sdecl id decl in let type_variance = compute_variance_decl env true decl @@ -2171,7 +2152,6 @@ let report_error ppf = function Remove the record field or change it to an object field (e.g. \"%s\": \ ...).@]" field_name - | Invalid_attribute msg -> fprintf ppf "%s" msg | Duplicate_label (s, Some record_name) -> fprintf ppf "The field @{%s@} is defined several times in the record \ diff --git a/compiler/ml/typedecl.mli b/compiler/ml/typedecl.mli index f12a53a967..8a534544f3 100644 --- a/compiler/ml/typedecl.mli +++ b/compiler/ml/typedecl.mli @@ -60,7 +60,6 @@ val check_coherence : Env.t -> Location.t -> Ident.t -> type_declaration -> unit val is_fixed_type : Parsetree.type_declaration -> bool (* for typeopt.ml *) -val get_unboxed_type_representation : Env.t -> type_expr -> type_expr option type error diff --git a/compiler/ml/typeopt.ml b/compiler/ml/typeopt.ml index 4ad9213b73..4d2be412ed 100644 --- a/compiler/ml/typeopt.ml +++ b/compiler/ml/typeopt.ml @@ -24,7 +24,7 @@ let scrape_ty env ty = | Tconstr (p, _, _) -> ( match Env.find_type p env with | {type_representation = Unboxed; _} -> ( - match Typedecl.get_unboxed_type_representation env ty with + match Ctype.get_unboxed_type_representation env ty with | None -> ty | Some ty2 -> ty2) | _ -> ty @@ -122,6 +122,28 @@ let rec cannot_contain_undefined ~visiting (typ : Types.type_expr) (env : Env.t) let type_cannot_contain_undefined typ env = cannot_contain_undefined ~visiting:[] typ env +type undefinedness = + | Cannot_be_undefined + | Unseen + | Stands_for_another + | Can_be_undefined + +(* Whether a type can hold [undefined], as far as the compiler sees. An + abstract type, also through an abbreviation, or a JavaScript object type + has a representation the compiler does not see; a functor parameter's or a + locally abstract type stands for any type. *) +let undefinedness env ty = + if type_cannot_contain_undefined ty env then Cannot_be_undefined + else + match (Ctype.expand_head_opt env ty).desc with + | Tconstr (path, _, _) -> ( + match Variant_layout.abstractness ~env path with + | Opaque -> Unseen + | Stands_for_another -> Stands_for_another + | Not_abstract -> Can_be_undefined) + | Tobject _ -> Unseen + | _ -> Can_be_undefined + let is_function_type env ty = match scrape env ty with | Tarrow (params, ret) -> Some ((List.hd params).typ, ret) diff --git a/compiler/ml/typeopt.mli b/compiler/ml/typeopt.mli index f51b0227f0..4bafce4bf7 100644 --- a/compiler/ml/typeopt.mli +++ b/compiler/ml/typeopt.mli @@ -22,3 +22,14 @@ val is_base_type : Env.t -> Types.type_expr -> Path.t -> bool val maybe_pointer_type : Env.t -> Types.type_expr -> Lambda.immediate_or_pointer val type_cannot_contain_undefined : Types.type_expr -> Env.t -> bool + +(** Whether a type can hold [undefined]: it cannot, the compiler does not see + its representation, it stands for another type (a functor parameter's or + a locally abstract type), or it can *) +type undefinedness = + | Cannot_be_undefined + | Unseen + | Stands_for_another + | Can_be_undefined + +val undefinedness : Env.t -> Types.type_expr -> undefinedness diff --git a/compiler/ml/variant_layout.ml b/compiler/ml/variant_layout.ml index 6bb51e8729..6a43673106 100644 --- a/compiler/ml/variant_layout.ml +++ b/compiler/ml/variant_layout.ml @@ -49,8 +49,13 @@ let declaration_shape ~env (decl : Types.type_declaration) : value_shape = | Some _ | None -> [] in Recognized_as (InstanceType (Class {name; ancestors})) - | None -> - if has_not_undefined decl.type_attributes then Never_undefined else Unstated + | None -> ( + if not (has_not_undefined decl.type_attributes) then Unstated + else + (* Restating a kind the abbreviated type is recognized by keeps it *) + match Option.map (value_shape ~env) decl.type_manifest with + | Some (Recognized_as _ as shape) -> shape + | Some (Unstated | Never_undefined) | None -> Never_undefined) (* Resolves the shapes of a group of declarations, which can abbreviate each other. Each round resolves one more level of abbreviation within the diff --git a/tests/build_tests/not_undefined_attribute/demo.res b/tests/build_tests/not_undefined_attribute/demo.res index cdd9eb9de1..5013452612 100644 --- a/tests/build_tests/not_undefined_attribute/demo.res +++ b/tests/build_tests/not_undefined_attribute/demo.res @@ -1,2 +1,2 @@ @notUndefined -type t = int +type t = option diff --git a/tests/build_tests/not_undefined_attribute/input.js b/tests/build_tests/not_undefined_attribute/input.js index b37a4d14e2..9b3200c91a 100644 --- a/tests/build_tests/not_undefined_attribute/input.js +++ b/tests/build_tests/not_undefined_attribute/input.js @@ -10,7 +10,11 @@ const { execBuild, execClean } = setup(import.meta.dirname); const out = await execBuild(); const stderr = normalizeNewlines(stripVTControlCharacters(out.stderr)); -assert.ok(stderr.includes("demo.res:2:1-12")); -assert.ok(stderr.includes("@notUndefined can only be used on abstract types")); +assert.ok(stderr.includes("demo.res:2:1-20")); +assert.ok( + stderr.includes( + "@notUndefined on a type abbreviation must describe an abstract type", + ), +); assert.ok(stderr.includes("Failed to Compile")); await execClean(); diff --git a/tests/build_tests/super_errors/expected/invalid_attribute_not_undefined.res.expected b/tests/build_tests/super_errors/expected/invalid_attribute_not_undefined.res.expected index fe75ea5d4e..30f9a87b73 100644 --- a/tests/build_tests/super_errors/expected/invalid_attribute_not_undefined.res.expected +++ b/tests/build_tests/super_errors/expected/invalid_attribute_not_undefined.res.expected @@ -1,9 +1,9 @@ We've found a bug for you! - /.../fixtures/invalid_attribute_not_undefined.res:2:1-12 + /.../fixtures/invalid_attribute_not_undefined.res:2:1-17 1 │ @notUndefined - 2 │ type t = int + 2 │ type t = {x: int} 3 │ - @notUndefined can only be used on abstract types \ No newline at end of file + @notUndefined can only be used on abstract types and type abbreviations, whose runtime representation it describes. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/not_undefined_on_functor_parameter_type.res.expected b/tests/build_tests/super_errors/expected/not_undefined_on_functor_parameter_type.res.expected new file mode 100644 index 0000000000..d9f374df59 --- /dev/null +++ b/tests/build_tests/super_errors/expected/not_undefined_on_functor_parameter_type.res.expected @@ -0,0 +1,11 @@ + + We've found a bug for you! + /.../fixtures/not_undefined_on_functor_parameter_type.res:6:17-28 + + 4 │ }, + 5 │ ) => { + 6 │ @notUndefined type t = X.t + 7 │ } + 8 │ + + @notUndefined cannot describe the type of a functor parameter, of a recursive module being defined, or a locally abstract type: such a type stands for another one, whose values can be anything. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/not_undefined_on_option.res.expected b/tests/build_tests/super_errors/expected/not_undefined_on_option.res.expected new file mode 100644 index 0000000000..720a9d0462 --- /dev/null +++ b/tests/build_tests/super_errors/expected/not_undefined_on_option.res.expected @@ -0,0 +1,8 @@ + + We've found a bug for you! + /.../fixtures/not_undefined_on_option.res:1:15-34 + + 1 │ @notUndefined type t = option + 2 │ + + @notUndefined on a type abbreviation must describe an abstract type, or a type with the same annotation. The abbreviated type already has a runtime representation the compiler knows, or can be undefined. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/invalid_attribute_not_undefined.res b/tests/build_tests/super_errors/fixtures/invalid_attribute_not_undefined.res index cdd9eb9de1..b57e947694 100644 --- a/tests/build_tests/super_errors/fixtures/invalid_attribute_not_undefined.res +++ b/tests/build_tests/super_errors/fixtures/invalid_attribute_not_undefined.res @@ -1,2 +1,2 @@ @notUndefined -type t = int +type t = {x: int} diff --git a/tests/build_tests/super_errors/fixtures/not_undefined_on_functor_parameter_type.res b/tests/build_tests/super_errors/fixtures/not_undefined_on_functor_parameter_type.res new file mode 100644 index 0000000000..ee01b578a1 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/not_undefined_on_functor_parameter_type.res @@ -0,0 +1,7 @@ +module Make = ( + X: { + type t + }, +) => { + @notUndefined type t = X.t +} diff --git a/tests/build_tests/super_errors/fixtures/not_undefined_on_option.res b/tests/build_tests/super_errors/fixtures/not_undefined_on_option.res new file mode 100644 index 0000000000..9f6d504453 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/not_undefined_on_option.res @@ -0,0 +1 @@ +@notUndefined type t = option diff --git a/tests/tests/src/as_constructor_name_test.res b/tests/tests/src/as_constructor_name_test.res index 678c15d0ba..c2fb3fb278 100644 --- a/tests/tests/src/as_constructor_name_test.res +++ b/tests/tests/src/as_constructor_name_test.res @@ -7,7 +7,7 @@ open Test_utils type named = A | B type declared = | @as("A") A | B | C -let declaredA = (A: named :> declared) +let declaredA = ((A: named) :> declared) module Stated: { type t = A | B diff --git a/tests/tests/src/not_undefined_abbreviation_test.mjs b/tests/tests/src/not_undefined_abbreviation_test.mjs new file mode 100644 index 0000000000..56fb3dbe1c --- /dev/null +++ b/tests/tests/src/not_undefined_abbreviation_test.mjs @@ -0,0 +1,46 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + +import * as Mocha from "mocha"; +import * as Test_utils from "./test_utils.mjs"; + +function kind(value) { + if (typeof value === "number") { + return "count"; + } else { + return value; + } +} + +function wrap(x) { + return x; +} + +function unwrap(x) { + if (x !== undefined) { + return "some"; + } else { + return "none"; + } +} + +let refinedValue = {}; + +Mocha.describe("Not_undefined_abbreviation_test", () => { + Mocha.test("a refined abstract type is not boxed in an option", () => { + Test_utils.eq("File \"not_undefined_abbreviation_test.res\", line 32, characters 7-14", refinedValue === refinedValue, true); + Test_utils.eq("File \"not_undefined_abbreviation_test.res\", line 33, characters 7-14", unwrap(refinedValue), "some"); + Test_utils.eq("File \"not_undefined_abbreviation_test.res\", line 34, characters 7-14", "none", "none"); + }); + Mocha.test("a restated builtin keeps its payload kind", () => { + Test_utils.eq("File \"not_undefined_abbreviation_test.res\", line 38, characters 7-14", "count", "count"); + Test_utils.eq("File \"not_undefined_abbreviation_test.res\", line 39, characters 7-14", "name", "name"); + }); +}); + +export { + kind, + wrap, + unwrap, + refinedValue, +} +/* Not a pure module */ diff --git a/tests/tests/src/not_undefined_abbreviation_test.res b/tests/tests/src/not_undefined_abbreviation_test.res new file mode 100644 index 0000000000..d9f978f153 --- /dev/null +++ b/tests/tests/src/not_undefined_abbreviation_test.res @@ -0,0 +1,41 @@ +open Mocha +open Test_utils + +// @notUndefined on an abbreviation refines a type whose representation the +// compiler does not see, or restates that a type cannot be undefined + +type opaque +@notUndefined type refined = opaque + +@notUndefined type count = int + +@unboxed +type value = Count(count) | Name(string) + +let kind = value => + switch value { + | Count(_) => "count" + | Name(name) => name + } + +let wrap = (x: refined) => Some(x) +let unwrap = (x: option) => + switch x { + | Some(_) => "some" + | None => "none" + } + +let refinedValue: refined = %raw(`{}`) + +describe(__MODULE__, () => { + test("a refined abstract type is not boxed in an option", () => { + eq(__LOC__, Obj.magic(wrap(refinedValue)) === refinedValue, true) + eq(__LOC__, unwrap(wrap(refinedValue)), "some") + eq(__LOC__, unwrap(None), "none") + }) + + test("a restated builtin keeps its payload kind", () => { + eq(__LOC__, kind(Count(1)), "count") + eq(__LOC__, kind(Name("name")), "name") + }) +}) From 34dd9df4f71aa5c39f5b64e0df3218c6ef00728d Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 24 Oct 2026 12:02:35 +0000 Subject: [PATCH 04/13] Fold matches of constructors by their runtime literals Why: A coercion accepts constructors whose literals are spelled differently but are the same value, such as `@as(1.)` for `@as(1.0)`, while a match on a constant constructor was folded by comparing tags structurally, so the coerced constant missed its arm. Constant constructors and tagged blocks are now found by the runtime value of their literal, as the untagged dispatch already does. JS modified (folded match of a coerced constant): Example: type source = | @as(1.) One type target = | @as(1.0) One | Two | Three | Four let isOne = (x: target) => switch x { | One => true | _ => false } let r = isOne((One: source :> target)) Before (js): let r = false; After (js): let r = true; Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- compiler/ml/lambda.ml | 22 +++++++++++++----- tests/tests/src/as_constructor_name_test.mjs | 18 +++++++++++++-- tests/tests/src/as_constructor_name_test.res | 24 ++++++++++++++++++++ 3 files changed, 56 insertions(+), 8 deletions(-) diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index b0ef179828..4ccc8cb996 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -908,11 +908,13 @@ let switch lam (lam_switch : lambda_switch) : t = match untagged_action facts cst with | `Case action -> action_or_switch action | `Undecided -> Lswitch (lam, lam_switch)) - | Lconst (Const_constructor cstr_name), _ -> + | Lconst (Const_constructor constant), _ -> + (* By runtime value: a coercion accepts [@as(1.)] for [@as(1.0)] *) let action = Ext_list.find_opt lam_switch.sw_consts (fun (key, action) -> match key with - | Switch_constructor (Constant tag) when cstr_name = tag -> + | Switch_constructor (Constant tag) + when literal_denotes_same constant.literal tag.literal -> Some action | Switch_int _ | Switch_constructor _ -> None) in @@ -940,13 +942,21 @@ let switch lam (lam_switch : lambda_switch) : t = | Blk_module _ | Blk_module_export _ | Blk_extension -> None in + let same_runtime (block : Variant_runtime.block) + (case : Variant_runtime.block) = + match (block, case) with + | Tagged block, Tagged case -> + block.tag_name = case.tag_name + && literal_denotes_same block.tag.literal case.tag.literal + | _ -> block = case + in let action = Ext_list.find_opt lam_switch.sw_blocks (fun (key, action) -> - match key with - | Switch_constructor (Block case_runtime) - when runtime = Some case_runtime -> + match (key, runtime) with + | Switch_constructor (Block case_runtime), Some runtime + when same_runtime runtime case_runtime -> Some action - | Switch_int _ | Switch_constructor _ -> None) + | (Switch_int _ | Switch_constructor _), _ -> None) in action_or_switch action | _ -> Lswitch (lam, lam_switch) diff --git a/tests/tests/src/as_constructor_name_test.mjs b/tests/tests/src/as_constructor_name_test.mjs index 6800be087e..a1373920ed 100644 --- a/tests/tests/src/as_constructor_name_test.mjs +++ b/tests/tests/src/as_constructor_name_test.mjs @@ -7,9 +7,21 @@ let Stated = { a: "A" }; +function isOne(x) { + return x === 1.0; +} + +function isOneOf(x) { + return x.TAG === 1.0; +} + Mocha.describe("As_constructor_name_test", () => { - Mocha.test("coercion", () => Test_utils.eq("File \"as_constructor_name_test.res\", line 22, characters 7-14", "A", "A")); - Mocha.test("interface", () => Test_utils.eq("File \"as_constructor_name_test.res\", line 26, characters 7-14", "A", "A")); + Mocha.test("coercion", () => Test_utils.eq("File \"as_constructor_name_test.res\", line 41, characters 7-14", "A", "A")); + Mocha.test("folded matches of coerced constants", () => { + Test_utils.eq("File \"as_constructor_name_test.res\", line 45, characters 7-14", true, true); + Test_utils.eq("File \"as_constructor_name_test.res\", line 46, characters 7-14", true, true); + }); + Mocha.test("interface", () => Test_utils.eq("File \"as_constructor_name_test.res\", line 50, characters 7-14", "A", "A")); }); let declaredA = "A"; @@ -17,5 +29,7 @@ let declaredA = "A"; export { declaredA, Stated, + isOne, + isOneOf, } /* Not a pure module */ diff --git a/tests/tests/src/as_constructor_name_test.res b/tests/tests/src/as_constructor_name_test.res index c2fb3fb278..0996fc9e75 100644 --- a/tests/tests/src/as_constructor_name_test.res +++ b/tests/tests/src/as_constructor_name_test.res @@ -17,11 +17,35 @@ module Stated: { let a = A } +// Literals are compared by runtime value, also when a match is folded +type sourceNumber = | @as(1.) One +type targetNumber = | @as(1.0) One | Two | Three | Four + +let isOne = (x: targetNumber) => + switch x { + | One => true + | _ => false + } + +type sourceBlock = | @as(1.) OneOf(int) +type targetBlock = | @as(1.0) OneOf(int) | TwoOf(int) + +let isOneOf = (x: targetBlock) => + switch x { + | OneOf(_) => true + | _ => false + } + describe(__MODULE__, () => { test("coercion", () => { eq(__LOC__, declaredA, A) }) + test("folded matches of coerced constants", () => { + eq(__LOC__, isOne((One: sourceNumber) :> targetNumber), true) + eq(__LOC__, isOneOf((OneOf(1): sourceBlock) :> targetBlock), true) + }) + test("interface", () => { eq(__LOC__, Stated.a, Stated.A) }) From 6978c6dfb385f8319b7c8866cc53fb383a4ee460 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 24 Oct 2026 16:46:20 +0000 Subject: [PATCH 05/13] Fold matches of numeric constants by their runtime value Why: A constant constructor represented by an int is lowered to an int, and a match on it was folded by comparing with the int tags of the matched variant only. A coercion accepts `@as(1)` for `@as(1.)`, so the coerced constant missed its arm. The int is compared with every constant's literal by value. JS modified (folded match of a coerced int constant): Example: type source = | @as(1) One type target = | @as(1.) One | Two | Three | Four let isOne = (x: target) => switch x { | One => true | _ => false } let r = isOne((One: source) :> target) Before (js): let r = false; After (js): let r = true; Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- compiler/ml/lambda.ml | 5 +++-- tests/tests/src/as_constructor_name_test.mjs | 14 ++++++++++---- tests/tests/src/as_constructor_name_test.res | 10 ++++++++++ 3 files changed, 23 insertions(+), 6 deletions(-) diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 4ccc8cb996..71cc84490b 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -927,8 +927,9 @@ let switch lam (lam_switch : lambda_switch) : t = Ext_list.find_opt lam_switch.sw_consts (fun (key, action) -> match key with | Switch_int ordinal when ordinal = i -> Some action - | Switch_constructor (Constant {literal = Variant_runtime.Int value}) - when value = i -> + | Switch_constructor (Constant {literal}) + when literal_denotes_same (Int i) literal -> + (* A constant represented as a number, compared by value *) Some action | Switch_int _ | Switch_constructor _ -> None) in diff --git a/tests/tests/src/as_constructor_name_test.mjs b/tests/tests/src/as_constructor_name_test.mjs index a1373920ed..74c585a112 100644 --- a/tests/tests/src/as_constructor_name_test.mjs +++ b/tests/tests/src/as_constructor_name_test.mjs @@ -11,17 +11,22 @@ function isOne(x) { return x === 1.0; } +function isOneInt(x) { + return x === 1; +} + function isOneOf(x) { return x.TAG === 1.0; } Mocha.describe("As_constructor_name_test", () => { - Mocha.test("coercion", () => Test_utils.eq("File \"as_constructor_name_test.res\", line 41, characters 7-14", "A", "A")); + Mocha.test("coercion", () => Test_utils.eq("File \"as_constructor_name_test.res\", line 50, characters 7-14", "A", "A")); Mocha.test("folded matches of coerced constants", () => { - Test_utils.eq("File \"as_constructor_name_test.res\", line 45, characters 7-14", true, true); - Test_utils.eq("File \"as_constructor_name_test.res\", line 46, characters 7-14", true, true); + Test_utils.eq("File \"as_constructor_name_test.res\", line 54, characters 7-14", true, true); + Test_utils.eq("File \"as_constructor_name_test.res\", line 55, characters 7-14", true, true); + Test_utils.eq("File \"as_constructor_name_test.res\", line 56, characters 7-14", true, true); }); - Mocha.test("interface", () => Test_utils.eq("File \"as_constructor_name_test.res\", line 50, characters 7-14", "A", "A")); + Mocha.test("interface", () => Test_utils.eq("File \"as_constructor_name_test.res\", line 60, characters 7-14", "A", "A")); }); let declaredA = "A"; @@ -30,6 +35,7 @@ export { declaredA, Stated, isOne, + isOneInt, isOneOf, } /* Not a pure module */ diff --git a/tests/tests/src/as_constructor_name_test.res b/tests/tests/src/as_constructor_name_test.res index 0996fc9e75..ff506e1314 100644 --- a/tests/tests/src/as_constructor_name_test.res +++ b/tests/tests/src/as_constructor_name_test.res @@ -27,6 +27,15 @@ let isOne = (x: targetNumber) => | _ => false } +type sourceInt = | @as(1) OneInt +type targetFloat = | @as(1.) OneInt | TwoInt | ThreeInt | FourInt + +let isOneInt = (x: targetFloat) => + switch x { + | OneInt => true + | _ => false + } + type sourceBlock = | @as(1.) OneOf(int) type targetBlock = | @as(1.0) OneOf(int) | TwoOf(int) @@ -44,6 +53,7 @@ describe(__MODULE__, () => { test("folded matches of coerced constants", () => { eq(__LOC__, isOne((One: sourceNumber) :> targetNumber), true) eq(__LOC__, isOneOf((OneOf(1): sourceBlock) :> targetBlock), true) + eq(__LOC__, isOneInt((OneInt: sourceInt) :> targetFloat), true) }) test("interface", () => { From 565d96ce73735255cee6a9cd56b202bec54a8c8e Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 24 Oct 2026 16:23:56 +0000 Subject: [PATCH 06/13] Move the variant invariant check next to the layout check_invariant checks a layout, and Variant_layout, which derives the layout, is its only caller; Ast_untagged_variants keeps the attributes and errors. Its doc comment, which described another function, now says what it checks. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- compiler/ml/UntaggedVariants.md | 2 +- compiler/ml/ast_untagged_variants.ml | 130 -------------------------- compiler/ml/variant_layout.ml | 131 +++++++++++++++++++++++++++ 3 files changed, 132 insertions(+), 131 deletions(-) diff --git a/compiler/ml/UntaggedVariants.md b/compiler/ml/UntaggedVariants.md index d28c056209..533ddd896b 100644 --- a/compiler/ml/UntaggedVariants.md +++ b/compiler/ml/UntaggedVariants.md @@ -262,7 +262,7 @@ A literal may equal a value of a payload case: `@as("a") A | S(string)`, `@as(true) A | B(bool)` are accepted. Rule 7 says which case such a value belongs to. -- Implementation: `ast_untagged_variants.ml:check_invariant`, +- Implementation: `variant_layout.ml:check_invariant`, `variant_runtime.ml:literal_value_key`. - Tests: the fixtures above; `tests/tests/src/unboxed_variant_fold_test.res` (a number and a bigint literal with the same digits); `TaggedDuplicateLiteral.res`, diff --git a/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml index c707a90cd5..398ac084ed 100644 --- a/compiler/ml/ast_untagged_variants.ml +++ b/compiler/ml/ast_untagged_variants.ml @@ -392,136 +392,6 @@ let is_nullary_variant (x : Types.constructor_arguments) = | Types.Cstr_tuple [] -> true | _ -> false -(* A literal's JavaScript value, which a [switch] compares with [===]. Ints - are emitted as 32-bit numbers, so [1], [1.0] and [4294967297] are one - number, while [1n] is a bigint. *) -let check_invariant ~(consts : (Location.t * tag) list) - ~(blocks : (Location.t * block) list) = - let module String_set = Set.Make (String) in - let module String_map = Map.Make (String) in - let string_literals_consts = ref String_set.empty in - let string_literals_blocks = ref String_set.empty in - (* Keyed by [literal_key], with the spelling of the literal *) - let nonstring_literals_consts = ref String_map.empty in - let nonstring_literals_blocks = ref String_map.empty in - let instance_types = Hashtbl.create 1 in - let function_types = ref 0 in - let object_types = ref 0 in - let string_types = ref 0 in - let number_types = ref 0 in - let bigint_types = ref 0 in - let boolean_types = ref 0 in - let symbol_types = ref 0 in - let unknown_types = ref 0 in - let add_string_literal ~is_const ~loc s = - let set = - if is_const then string_literals_consts else string_literals_blocks - in - if String_set.mem s !set then - raise (Error (loc, InvalidUntaggedVariantDefinition (DuplicateLiteral s))); - set := String_set.add s !set - in - let add_nonstring_literal ~is_const ~loc literal s = - let map = - if is_const then nonstring_literals_consts else nonstring_literals_blocks - in - let key = Variant_runtime.literal_value_key literal in - (match String_map.find_opt key !map with - | Some earlier when earlier = s -> - raise (Error (loc, InvalidUntaggedVariantDefinition (DuplicateLiteral s))) - | Some earlier -> - raise - (Error - ( loc, - InvalidUntaggedVariantDefinition (SameLiteralValue (s, earlier)) )) - | None -> ()); - map := String_map.add key s !map - in - let invariant loc name = - if !unknown_types <> 0 && List.length blocks <> 1 then - raise - (Error (loc, InvalidUntaggedVariantDefinition (OnlyOneUnknown name))); - if !object_types > 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneObject)); - Hashtbl.iter - (fun _ (i, count) -> - if count > 1 then - raise - (Error (loc, InvalidUntaggedVariantDefinition (AtMostOneInstance i)))) - instance_types; - if !function_types > 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneFunction)); - if !string_types > 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneString)); - if !number_types > 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneNumber)); - if !bigint_types > 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneBigint)); - if !boolean_types > 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneBoolean)); - if !symbol_types > 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneSymbol)); - () - in - let check_literal ~is_const ~loc (tag : tag) = - match tag.literal with - | String s -> add_string_literal ~is_const ~loc s - | Int i as literal -> - add_nonstring_literal ~is_const ~loc literal (string_of_int i) - | Float f as literal -> add_nonstring_literal ~is_const ~loc literal f - | BigInt i as literal -> - add_nonstring_literal ~is_const ~loc literal (i ^ "n") - | Bool b as literal -> - add_nonstring_literal ~is_const ~loc literal - (if b then "true" else "false") - | Null as literal -> add_nonstring_literal ~is_const ~loc literal "null" - | Undefined as literal -> - add_nonstring_literal ~is_const ~loc literal "undefined" - in - - Ext_list.rev_iter consts (fun (loc, literal) -> - check_literal ~is_const:true ~loc literal); - (* The blocks of a variant are all tagged or, when the type is [@unboxed], - all untagged. A tagged block is told apart from the others by its tag; an - untagged one by the kind of its payload, whatever its [@as]. *) - Ext_list.rev_iter blocks (fun (loc, block) -> - match block with - | Tagged {tag} -> check_literal ~is_const:false ~loc tag - | Untagged {tag; block_type} -> - (match block_type with - | UnknownType -> incr unknown_types - | ObjectType -> incr object_types - | InstanceType i -> - (* A class is identified by its name *) - let name = Instance.to_string i in - let count = - match Hashtbl.find_opt instance_types name with - | Some (_, count) -> count - | None -> 0 - in - Hashtbl.replace instance_types name (i, count + 1) - | SymbolType -> incr symbol_types - | FunctionType -> incr function_types - | NumberType -> incr number_types - | BigintType -> incr bigint_types - | BooleanType -> - (* Literal cases are matched before payload cases, so a boolean - payload only receives the booleans that are not literal cases. - A partial overlap is allowed, like for strings and numbers. *) - if - String_map.mem "true" !nonstring_literals_consts - && String_map.mem "false" !nonstring_literals_consts - then - raise - (Error - ( loc, - InvalidUntaggedVariantDefinition - (UnreachableBoolean tag.name) )); - incr boolean_types - | StringType -> incr string_types); - invariant loc tag.name) - -(* A constructor without [@as] is represented by its name *) let declared_tag (cstr : Types.constructor_declaration) = let name = Ident.name cstr.cd_id in {name; literal = Option.value cstr.cd_runtime_tag ~default:(String name)} diff --git a/compiler/ml/variant_layout.ml b/compiler/ml/variant_layout.ml index 6a43673106..51b920d2e4 100644 --- a/compiler/ml/variant_layout.ml +++ b/compiler/ml/variant_layout.ml @@ -193,6 +193,137 @@ let get_block_type ~env (cstr : Types.constructor_declaration) : block_type = (* Nullary constructors are handled before computing a payload shape. *) assert false +(* The cases of a variant must be told apart at run time: nullary cases and + tagged blocks by distinct literals, the untagged payloads of an [@unboxed] + variant by distinct kinds *) +let check_invariant ~(consts : (Location.t * tag) list) + ~(blocks : (Location.t * block) list) = + let module String_set = Set.Make (String) in + let module String_map = Map.Make (String) in + let string_literals_consts = ref String_set.empty in + let string_literals_blocks = ref String_set.empty in + (* Keyed by [literal_key], with the spelling of the literal *) + let nonstring_literals_consts = ref String_map.empty in + let nonstring_literals_blocks = ref String_map.empty in + let instance_types = Hashtbl.create 1 in + let function_types = ref 0 in + let object_types = ref 0 in + let string_types = ref 0 in + let number_types = ref 0 in + let bigint_types = ref 0 in + let boolean_types = ref 0 in + let symbol_types = ref 0 in + let unknown_types = ref 0 in + let add_string_literal ~is_const ~loc s = + let set = + if is_const then string_literals_consts else string_literals_blocks + in + if String_set.mem s !set then + raise (Error (loc, InvalidUntaggedVariantDefinition (DuplicateLiteral s))); + set := String_set.add s !set + in + let add_nonstring_literal ~is_const ~loc literal s = + let map = + if is_const then nonstring_literals_consts else nonstring_literals_blocks + in + let key = Variant_runtime.literal_value_key literal in + (match String_map.find_opt key !map with + | Some earlier when earlier = s -> + raise (Error (loc, InvalidUntaggedVariantDefinition (DuplicateLiteral s))) + | Some earlier -> + raise + (Error + ( loc, + InvalidUntaggedVariantDefinition (SameLiteralValue (s, earlier)) )) + | None -> ()); + map := String_map.add key s !map + in + let invariant loc name = + if !unknown_types <> 0 && List.length blocks <> 1 then + raise + (Error (loc, InvalidUntaggedVariantDefinition (OnlyOneUnknown name))); + if !object_types > 1 then + raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneObject)); + Hashtbl.iter + (fun _ (i, count) -> + if count > 1 then + raise + (Error (loc, InvalidUntaggedVariantDefinition (AtMostOneInstance i)))) + instance_types; + if !function_types > 1 then + raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneFunction)); + if !string_types > 1 then + raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneString)); + if !number_types > 1 then + raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneNumber)); + if !bigint_types > 1 then + raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneBigint)); + if !boolean_types > 1 then + raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneBoolean)); + if !symbol_types > 1 then + raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneSymbol)); + () + in + let check_literal ~is_const ~loc (tag : tag) = + match tag.literal with + | String s -> add_string_literal ~is_const ~loc s + | Int i as literal -> + add_nonstring_literal ~is_const ~loc literal (string_of_int i) + | Float f as literal -> add_nonstring_literal ~is_const ~loc literal f + | BigInt i as literal -> + add_nonstring_literal ~is_const ~loc literal (i ^ "n") + | Bool b as literal -> + add_nonstring_literal ~is_const ~loc literal + (if b then "true" else "false") + | Null as literal -> add_nonstring_literal ~is_const ~loc literal "null" + | Undefined as literal -> + add_nonstring_literal ~is_const ~loc literal "undefined" + in + + Ext_list.rev_iter consts (fun (loc, literal) -> + check_literal ~is_const:true ~loc literal); + (* The blocks of a variant are all tagged or, when the type is [@unboxed], + all untagged. A tagged block is told apart from the others by its tag; an + untagged one by the kind of its payload, whatever its [@as]. *) + Ext_list.rev_iter blocks (fun (loc, block) -> + match block with + | Tagged {tag} -> check_literal ~is_const:false ~loc tag + | Untagged {tag; block_type} -> + (match block_type with + | UnknownType -> incr unknown_types + | ObjectType -> incr object_types + | InstanceType i -> + (* A class is identified by its name *) + let name = Instance.to_string i in + let count = + match Hashtbl.find_opt instance_types name with + | Some (_, count) -> count + | None -> 0 + in + Hashtbl.replace instance_types name (i, count + 1) + | SymbolType -> incr symbol_types + | FunctionType -> incr function_types + | NumberType -> incr number_types + | BigintType -> incr bigint_types + | BooleanType -> + (* Literal cases are matched before payload cases, so a boolean + payload only receives the booleans that are not literal cases. + A partial overlap is allowed, like for strings and numbers. *) + if + String_map.mem "true" !nonstring_literals_consts + && String_map.mem "false" !nonstring_literals_consts + then + raise + (Error + ( loc, + InvalidUntaggedVariantDefinition + (UnreachableBoolean tag.name) )); + incr boolean_types + | StringType -> incr string_types); + invariant loc tag.name) + +(* A constructor without [@as] is represented by its name *) + let layout_from_type_variant ~(configuration : configuration) ~env (cstrs : Types.constructor_declaration list) : Variant_runtime.layout = let get_block (cstr : Types.constructor_declaration) : block = From f851d1a1c150b870e40ca7bafbfba106d0286234 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 24 Oct 2026 16:25:36 +0000 Subject: [PATCH 07/13] Compare every runtime shape claim of an interface in one place Interface inclusion compared classes and kinds in Includecore and @notUndefined in Includemod, the two levels of one declared shape. Includecore.compare_runtime_annotations now checks both; the messages are unchanged. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- compiler/ml/UntaggedVariants.md | 2 +- compiler/ml/includecore.ml | 22 +++++++++++++++++----- compiler/ml/includemod.ml | 20 -------------------- 3 files changed, 18 insertions(+), 26 deletions(-) diff --git a/compiler/ml/UntaggedVariants.md b/compiler/ml/UntaggedVariants.md index 533ddd896b..a317c74b6c 100644 --- a/compiler/ml/UntaggedVariants.md +++ b/compiler/ml/UntaggedVariants.md @@ -493,7 +493,7 @@ for functor arguments and `with type` constraints. `ast_untagged_variants.ml:has_not_undefined`; `variant_layout.ml:declaration_shape`; `typeopt.ml:type_cannot_contain_undefined`; - `includemod.ml:not_undefined_mismatch`. + `includecore.ml:compare_runtime_annotations`. - Tests: `spec_test` rule 13; fixtures `invalid_attribute_not_undefined.res`, `not_undefined_functor_argument.res`, `not_undefined_functor_parameter.res`; `tests/tests/src/not_undefined_interface_test.res`, diff --git a/compiler/ml/includecore.ml b/compiler/ml/includecore.ml index 62d1546b67..fe6bdee271 100644 --- a/compiler/ml/includecore.ml +++ b/compiler/ml/includecore.ml @@ -345,13 +345,25 @@ and compare_records env params1_ params2_ n_ in aux ~fast:true params1_ params2_ n_ labels1_ labels2_ -(* Values are recognized by the class or [typeof] the second declaration - states, so the first must state the same. Stating nothing hides it. *) -let compare_runtime_annotations env decl1 decl2 = +(* What the second declaration states about its values at run time must + hold for the first. Values are recognized by the class or [typeof] the + second states, so the first must state the same; stating nothing hides it. + [@notUndefined] lets clients unbox [option] of the type, so the first must + be a type that cannot hold [undefined] either, or one whose representation + the compiler does not see, which has none that contradicts it. *) +let compare_runtime_annotations env id decl1 decl2 = (* The second declaration's shape was resolved in its own environment, so it is what users of the second declaration see *) match decl2.type_shape with - | Unstated | Never_undefined -> [] + | Unstated -> [] + | Never_undefined -> ( + let env = Env.add_type ~check:false id decl1 env in + let ty = + Btype.newgenty (Tconstr (Pident id, decl1.type_params, ref Mnil)) + in + match Typeopt.undefinedness env ty with + | Cannot_be_undefined | Unseen -> [] + | Stands_for_another | Can_be_undefined -> [Not_undefined]) | Recognized_as block_type2 -> let declared2 = Some block_type2 in let declared1 = @@ -395,7 +407,7 @@ let type_declarations ?(equality = false) ~loc env name decl1 id decl2 = else [Constraint] in let err = - if err <> [] then err else compare_runtime_annotations env decl1 decl2 + if err <> [] then err else compare_runtime_annotations env id decl1 decl2 in if err <> [] then err else diff --git a/compiler/ml/includemod.ml b/compiler/ml/includemod.ml index fbd64367ad..890c6c97de 100644 --- a/compiler/ml/includemod.ml +++ b/compiler/ml/includemod.ml @@ -62,32 +62,12 @@ let value_descriptions ~loc env cxt subst id vd1 vd2 = (* Inclusion between type declarations *) -(* [@notUndefined] lets clients unbox [option] of the type, so the - implementation must be a type that cannot hold [undefined] either, or one - whose representation the compiler does not see, which has none that - contradicts it. *) -let not_undefined_mismatch env id (decl1 : Types.type_declaration) - (decl2 : Types.type_declaration) = - match decl2.type_shape with - | Unstated | Recognized_as _ -> [] - | Never_undefined -> ( - let env = Env.add_type ~check:false id decl1 env in - let ty = - Btype.newgenty (Tconstr (Pident id, decl1.type_params, ref Mnil)) - in - match Typeopt.undefinedness env ty with - | Cannot_be_undefined | Unseen -> [] - | Stands_for_another | Can_be_undefined -> [Includecore.Not_undefined]) - let type_declarations ~loc env ?(old_env = env) cxt subst id decl1 decl2 = Env.mark_type_used env (Ident.name id) decl1; let decl2 = Subst.type_declaration subst decl2 in let err = Includecore.type_declarations ~loc env (Ident.name id) decl1 id decl2 in - let err = - if err <> [] then err else not_undefined_mismatch env id decl1 decl2 - in if err <> [] then raise (Error [(cxt, old_env, Type_declarations (id, decl1, decl2, err))]) From d14444b5cfe4f842b7c26b780774be5c11942c17 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sun, 25 Oct 2026 05:11:52 +0000 Subject: [PATCH 08/13] Merge the @notUndefined rule into the rule on declared shapes `@notUndefined`, `@typeOf` and `@instanceOf` declare levels of one stored shape, checked on abbreviations by one entry point and across interfaces by one comparer. Rule 5 now describes the three together, with their errors and interface checks; rule 13 is gone and the rule on `@tag` and interfaces becomes rule 13. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- compiler/ml/UntaggedVariants.md | 162 ++++++++---------- .../tests/src/untagged_variants_spec_test.mjs | 4 +- .../tests/src/untagged_variants_spec_test.res | 4 +- 3 files changed, 75 insertions(+), 95 deletions(-) diff --git a/compiler/ml/UntaggedVariants.md b/compiler/ml/UntaggedVariants.md index a317c74b6c..68b348a354 100644 --- a/compiler/ml/UntaggedVariants.md +++ b/compiler/ml/UntaggedVariants.md @@ -127,20 +127,28 @@ builtin payload type. `@notUndefined` on an abstract type leaves it unknown. `untagged_builtin_alias_test.res`. - Shaped by #6121, #6208, #6219, #6279, #6368, #6394, #6550, #6670. -### 5. Declared instance types +### 5. Declared runtime shapes -`@instanceOf("C")` on a type declares that its values are instances of the -global class at the path `C`, such as `"Date"` or `"Intl.Locale"`. -`@typeOf("k")` declares that their `typeof` is `k`, one of `"string"`, -`"number"`, `"bigint"`, `"boolean"`, `"symbol"`, `"function"` and -`"object"`. A type has at most one of the two, and only abstract types and -type abbreviations, public or private, can have them. +Three annotations declare what the values of a type are at run time, each +level implying the one before: + +- `@notUndefined`: they are never `undefined`; +- `@typeOf("k")`: their `typeof` is `k`, one of `"string"`, `"number"`, + `"bigint"`, `"boolean"`, `"symbol"`, `"function"` and `"object"`; +- `@instanceOf("C")`: they are instances of the global class at the path `C`, + such as `"Date"` or `"Intl.Locale"`. + +A type has at most one of `@typeOf` and `@instanceOf`, and only abstract types +and type abbreviations, public or private, can have any of the three. +`@notUndefined` affects only rule 12: `option` of the type, and of an untagged +variant with a payload of the type, is unboxed. It does not make the type a +recognized payload kind (rule 4). When a type is declared, its annotation is resolved into its *shape*, which -is stored on the declaration: the class with its superclasses, or the -`typeof` kind (`@notUndefined` gives the shape "never undefined", rule 13). -The classes annotated further down a chain of abbreviations are the -superclasses (rule 8): +is stored on the declaration: "never undefined", the `typeof` kind, or the +class with its superclasses. The builtin types state their shapes in their +declarations (rule 4). The classes annotated further down a chain of +abbreviations are the superclasses (rule 8): ```rescript @instanceOf("Animal") type animal @@ -151,14 +159,16 @@ The classifier and every other reader take the shape of the payload type as written, or of the first type it abbreviates that states one, so the outermost annotation decides. A shape is resolved in the environment the type is declared in, so an interface's shape is what its users see, even -where the implementation knows more (rule 14). An annotation that repeats +where the implementation knows more. An annotation that repeats the abbreviated type's, as the declarations of a module alias do, adds no superclass. An annotation on an abbreviation must agree with the abbreviated type. It can -refine an abstract type that is not builtin and has no annotation, or repeat -what the abbreviated type is recognized by, as `@typeOf("number") type count = -int` does. The type of a functor parameter, of a +refine a type whose representation the compiler does not see, an abstract +type that is not builtin and has no annotation, or restate what the +abbreviated type is known to be, as `@typeOf("number") type count = int` and +`@notUndefined type count = int` do; a restating `@notUndefined` keeps the +kind of `int`. The type of a functor parameter, of a recursive module being defined, and a locally abstract type `(type a)` are abstract only where they are declared: they stand for another type, so they cannot be refined. Only a private abbreviation can declare a subclass of the @@ -171,14 +181,34 @@ would `type dog = animal` or `type dog = phantom` with | Declaration | Error | Fixture | | --- | --- | --- | | `@typeOf("string") type t = option`, `type t<'a> = 'a`, an abbreviation of `unit`, `list<_>`, a record or a variant | @typeOf on a type abbreviation must describe an abstract type, ... | `runtime_annotation_on_option.res`, `runtime_annotation_on_type_variable.res` | +| `@notUndefined type t = option` | @notUndefined on a type abbreviation must describe an abstract type, ... | `not_undefined_on_option.res`, `tests/build_tests/not_undefined_attribute` | | `@typeOf("number") type t = sym` with `@typeOf("symbol") type sym`, or `@typeOf("string") type t = int` | This annotation, @typeOf("number"), contradicts the abbreviated type, whose values are recognized by @typeOf("symbol"). | `runtime_annotation_contradicts_manifest.res`, `runtime_annotation_contradicts_builtin.res` | -| `@instanceOf("Date") type date = X.t` in a functor of `X`, or over `(type a)` | @instanceOf cannot describe the type of a functor parameter, ... | `instance_of_functor_parameter.res`, `type_of_locally_abstract_type.res` | +| `@instanceOf("Date") type date = X.t` in a functor of `X`, or over `(type a)`; `@notUndefined type t = X.t` | @instanceOf cannot describe the type of a functor parameter, ... | `instance_of_functor_parameter.res`, `type_of_locally_abstract_type.res`, `not_undefined_on_functor_parameter_type.res` | | `@instanceOf("Dog") type dog = animal`, `= animal`, or `= phantom` with `type phantom<'a> = animal` | A subclass must be a private abbreviation ... | `instance_of_public_subclass.res`, `instance_of_public_subclass_instance.res`, `instance_of_public_subclass_through_alias.res` | | `@instanceOf("Animal") type t = private dog` | Animal appears twice in this chain of abbreviations ... | `instance_of_class_twice_in_chain.res` | -| `@instanceOf` on a record or variant | @instanceOf can only be used on abstract types and type abbreviations ... | `runtime_annotation_on_record.res` | -| both annotations | A type can have either @instanceOf or @typeOf, not both. | `runtime_annotation_conflict.res` | +| any of the three on a record or variant | @instanceOf can only be used on abstract types and type abbreviations ... | `runtime_annotation_on_record.res`, `invalid_attribute_not_undefined.res` | +| both `@instanceOf` and `@typeOf` | A type can have either @instanceOf or @typeOf, not both. | `runtime_annotation_conflict.res` | | one annotation twice | Duplicate @instanceOf annotation; a type can have only one. | `instance_of_duplicate.res` | +What an interface states about a type must hold for its implementation. A +class or `typeof`, stated through its own annotation or the type it +abbreviates, must be the one the implementation states, superclasses +included: "Their runtime representations differ". A builtin type states its +kind, so `@typeOf("number") type t` in an interface accepts `type t = int` +(`untagged_builtin_alias_test.res`). Under `@notUndefined`, the +implementation must be a type that cannot hold `undefined` either, or one +whose representation the compiler does not see, which has none to contradict +it: an abstract type, also through an abbreviation such as +`type t = Dom.element`, or a JavaScript object type; a functor parameter's or +a locally abstract type stands for another type and does not count. +`type t = option` under `@notUndefined type t` is an error: "the second +declaration is @notUndefined, but the first declaration can hold undefined". +An interface that states nothing hides the shape. The same holds for functor +arguments, `with type` constraints and module type ascriptions. Within one +variant a class is identified by its path, so two types of the same class are +one case (rule 6); across a signature the two declarations must also state +the same superclasses. + The class path is a dot-separated list of identifiers whose first one is not a JavaScript keyword. Paths that name no class to recognize values by are rejected as well: @@ -216,16 +246,26 @@ written (Known bugs). - Implementation: `types.mli:type_shape`, `variant_runtime.mli:value_shape`; `variant_layout.ml:declaration_shape`, `resolve_shapes`, `value_shape`, `check_manifest_annotation`; - `ast_untagged_variants.ml:process_runtime_annotation`, `unsupported_class`, - `check_runtime_annotation`; + `typedecl.ml:check_manifest_annotations`; `typeopt.ml:undefinedness`; + `ast_untagged_variants.ml:process_runtime_annotation`, `has_not_undefined`, + `unsupported_class`, `check_runtime_annotation`; + `includecore.ml:compare_runtime_annotations`; `variant_runtime.ml:Instance`; `js_exp_make.ml:class_constructor`. - Tests: `spec_test` rules 4 and 5; `tests/tests/src/untagged_runtime_annotations_test.res`, `untagged_runtime_annotations_shadow_test.res`, - `untagged_file_blob_test.res`; the fixtures above, - `UntaggedAtMostOneInstance.res`, `UntaggedTupleAndArray.res`. -- Shaped by #6296, #6383, #6396, #7788, #8009, #8950, #8948, #8949. - Related: #7147. + `untagged_file_blob_test.res`, `not_undefined_interface_test.res`, + `not_undefined_abbreviation_test.res`; the fixtures above, + `UntaggedAtMostOneInstance.res`, `UntaggedTupleAndArray.res`, + `not_undefined_functor_argument.res`, `not_undefined_functor_parameter.res`; + `tests/build_tests/super_errors_multi/fixtures/` + `Cross_runtime_annotation_hidden_superclass`, + `Cross_runtime_annotation_hidden_base`, + `Cross_runtime_annotation_claimed_by_interface`, + `Cross_runtime_annotation_functor_argument`, + `Cross_not_undefined_option_implementation`. +- Shaped by #6296, #6383, #6396, #7458, #7464, #7788, #8009, #8950, #8948, + #8949, #8964. Related: #7147. ### 6. Well-formedness @@ -425,7 +465,7 @@ as `Primitive_option.some(v)` otherwise. An untagged variant cannot hold | `string`, `int`, `float`, `bool`, `bigint`, a function, a tuple, a record without `@unboxed` | no | | an inline record with two or more fields | no | | an `@unboxed` record, an inline record with one field | as the type of its field | -| an abstract type with `@notUndefined` (rule 13), a type declared with `@instanceOf` or `@typeOf` (rule 5), an `@unboxed` wrapper of either | no | +| a type declared with `@notUndefined`, `@instanceOf` or `@typeOf` (rule 5), an `@unboxed` wrapper of one | no | | an abstract type without it, a type variable, `option<_>` | yes | | a type whose declaration is not on the load path | yes | @@ -458,51 +498,7 @@ hold `undefined`. `tests/build_tests/option_transitive_dependency`. - Shaped by #6222, #6233, #8719, #8954. -### 13. `@notUndefined` - -`@notUndefined` on an abstract type declares that its values are never -`undefined`. It affects only rule 12: `option` of the type, and of an -untagged variant with a payload of the type, is unboxed. It does not make the -type a recognized payload kind (rule 4). `@instanceOf` and `@typeOf` (rule 5) -imply it. - -On an abbreviation it follows the rule of rule 5: it can refine a type whose -representation the compiler does not see, such as an abstract type, or -restate that the abbreviated type cannot be `undefined`, as -`@notUndefined type count = int` does, which keeps the kind of `int`. - -| Declaration | Error | Fixture | -| --- | --- | --- | -| `@notUndefined type t = {x: int}`, or on a variant | @notUndefined can only be used on abstract types and type abbreviations, ... | `invalid_attribute_not_undefined.res` | -| `@notUndefined type t = option` | @notUndefined on a type abbreviation must describe an abstract type, ... | `not_undefined_on_option.res`, `tests/build_tests/not_undefined_attribute` | -| `@notUndefined type t = X.t` in a functor of `X` | @notUndefined cannot describe the type of a functor parameter, ... | `not_undefined_on_functor_parameter_type.res` | - -When an interface declares a type `@notUndefined`, its implementation must be -a type that cannot hold `undefined` either, or a type whose representation -the compiler does not see, which has none to contradict it: an abstract type, -also through an abbreviation such as `type t = Dom.element`, or a JavaScript -object type. The type of a functor parameter or a locally abstract type -stands for another type and does not count as abstract. `type t = option` under -`@notUndefined type t` is an error: "Their runtime representations -differ: the second declaration is @notUndefined, but the first declaration -can hold undefined". The same holds -for functor arguments and `with type` constraints. - -- Implementation: `typedecl.ml:transl_declaration`, - `check_not_undefined_manifest`; `typeopt.ml:undefinedness`; - `ast_untagged_variants.ml:has_not_undefined`; - `variant_layout.ml:declaration_shape`; - `typeopt.ml:type_cannot_contain_undefined`; - `includecore.ml:compare_runtime_annotations`. -- Tests: `spec_test` rule 13; fixtures `invalid_attribute_not_undefined.res`, - `not_undefined_functor_argument.res`, `not_undefined_functor_parameter.res`; - `tests/tests/src/not_undefined_interface_test.res`, - `not_undefined_abbreviation_test.res`; - `tests/build_tests/super_errors_multi/fixtures/Cross_not_undefined_option_implementation`; - `tests/build_tests/not_undefined_attribute`. -- Shaped by #7458, #7464, #8964. - -### 14. `@tag` and interfaces +### 13. `@tag` and interfaces In a tagged variant, `@tag("f")` names the field that holds the tag of a case with a payload (`TAG` by default), and `@as` on such a case sets the tag's @@ -519,29 +515,14 @@ not checked, so it agrees with any payload of the implementation payload does not change its representation (rule 2) and is not compared. Type declarations in messages print the `@as` of nullary and tagged cases. -A type for which an interface states a class or `typeof` (rule 5), through -its own annotation or the type it abbreviates, must state the same one in the -implementation, superclasses included: "Their runtime representations -differ". A builtin type states its kind, so `@typeOf("number") type t` in an -interface accepts `type t = int` (`untagged_builtin_alias_test.res`). An -interface that states none hides it. The same holds for functor -arguments, `with type` constraints and module type ascriptions. Within one -variant a class is identified by its path, so two types of the same class are -one case (rule 6); across a signature the two declarations must also state -the same superclasses. - - Implementation: `variant_layout.ml:layout_from_type_variant`, `ast_untagged_variants.ml:process_tag_name`, `check_tag_field_conflicts`; `includecore.ml:compare_variants`, `type_declarations`. -- Tests: `spec_test` rule 14; fixtures `UntaggedTagFieldNameConflict.res`, +- Tests: `spec_test` rule 13; fixtures `UntaggedTagFieldNameConflict.res`, `variant_tag_overlaps_with_field.res`, `UntaggedInvalidVariantTagAnnotation.res`, `UntaggedImplIntf.res`; `tests/build_tests/super_errors_multi/fixtures/` `Iface_unboxed_variant_mismatch`, `Iface_tag_name_mismatch`, - `Iface_variant_representation_mismatch`, - `Cross_runtime_annotation_hidden_superclass`, - `Cross_runtime_annotation_hidden_base`, - `Cross_runtime_annotation_claimed_by_interface`, - `Cross_runtime_annotation_functor_argument`; `variant_payload_tag_mismatch.res`. + `Iface_variant_representation_mismatch`; `variant_payload_tag_mismatch.res`. - Shaped by #6498, #6513, #6669, #7875, #8956. ## Known bugs @@ -570,15 +551,14 @@ had to answer, and the answers of rule 5: down its chain of private abbreviations. A superclass case excludes its subclass cases in any order, and an upcast value lands in the subclass case (rule 8). The relation must be visible where the variant is declared: an interface that - hides it is rejected (rule 14). + hides it is rejected (rule 5). 3. **Overlaps across kinds.** `Object`, `Function`, `Array` and the wrappers of primitives are rejected as classes. A declared kind counts as the builtin kind (rule 6). Unrelated classes are tested in declaration order. 4. **The unchecked branch** stays the contract (rule 10). 5. **Realms.** Recognition is local to a realm (rule 10). -6. **Interfaces and functors** compare declared classes and kinds, and the - payload kinds of untagged cases (rule 14), and `@notUndefined` against - the implementation (rule 13). +6. **Interfaces and functors** compare declared shapes (rule 5) and the + payload kinds of untagged cases (rule 13). 7. **Implied `@notUndefined`.** A declared class or kind implies it, and rule 5 rejects annotations on abbreviations of types that can hold `undefined`. diff --git a/tests/tests/src/untagged_variants_spec_test.mjs b/tests/tests/src/untagged_variants_spec_test.mjs index 0612499b8e..1e6cf24336 100644 --- a/tests/tests/src/untagged_variants_spec_test.mjs +++ b/tests/tests/src/untagged_variants_spec_test.mjs @@ -354,11 +354,11 @@ Mocha.describe("Untagged_variants_spec_test", () => { Test_utils.eq("File \"untagged_variants_spec_test.res\", line 336, characters 7-14", someWithUnboxedOption(undefined) === undefined, false); Test_utils.eq("File \"untagged_variants_spec_test.res\", line 337, characters 7-14", someWithUnboxedString(undefined) === undefined, true); }); - Mocha.test("rule 13: @notUndefined unboxes option of a variant holding the type", () => { + Mocha.test("rule 5: @notUndefined unboxes option of a variant holding the type", () => { Test_utils.eq("File \"untagged_variants_spec_test.res\", line 341, characters 7-14", someWithDefined(undefined) === undefined, true); Test_utils.eq("File \"untagged_variants_spec_test.res\", line 342, characters 7-14", someWithDefined(5), 5); }); - Mocha.test("rule 14: @tag and @as on a tagged variant", () => { + Mocha.test("rule 13: @tag and @as on a tagged variant", () => { Test_utils.eq("File \"untagged_variants_spec_test.res\", line 346, characters 7-14", id({ kind: "TA", x: 1 diff --git a/tests/tests/src/untagged_variants_spec_test.res b/tests/tests/src/untagged_variants_spec_test.res index fc65258e76..1773fe855d 100644 --- a/tests/tests/src/untagged_variants_spec_test.res +++ b/tests/tests/src/untagged_variants_spec_test.res @@ -337,12 +337,12 @@ describe(__MODULE__, () => { eq(__LOC__, someWithUnboxedString(UString(raw(Nullable.undefined))) == None, true) }) - test("rule 13: @notUndefined unboxes option of a variant holding the type", () => { + test("rule 5: @notUndefined unboxes option of a variant holding the type", () => { eq(__LOC__, someWithDefined(Defined(raw(Nullable.undefined))) == None, true) eq(__LOC__, raw(someWithDefined(Defined(raw(5)))), 5) }) - test("rule 14: @tag and @as on a tagged variant", () => { + test("rule 13: @tag and @as on a tagged variant", () => { eq(__LOC__, raw(id(TA({x: 1}))), {"kind": "TA", "x": 1}) eq(__LOC__, raw(id(TB({y: 1}))), {"kind": "bee", "y": 1}) eq(__LOC__, raw(id(TC)), "TC") From 63b3da29e8d0c788b6d8d0d3b5677f5265a8ff29 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sun, 25 Oct 2026 14:05:38 +0000 Subject: [PATCH 09/13] Classify payload types once for every reader of runtime shapes Why: Untagged payloads, annotations on abbreviations and interfaces each classified types their own way, so the latter two rejected annotations that only restate what a function type or a record is. `Variant_layout.payload_kind` gives the declared shape of a type, or the kind its structure gives: a tuple is an array, a function type a function, a record an object. `get_block_type`, `check_manifest_annotation` and `Includecore.compare_runtime_annotations` all use it. Typing rules changed (an annotation restating a structural kind): Example: @typeOf("function") type callback = int => int module M: { @typeOf("object") type point } = { type point = {py: int} } Before (rule): an annotation on an abbreviation agrees with the type's declared shape; an implementation states the shape it declares or abbreviates. After (rule): both compare with the payload kind of rule 4, which also covers tuples, function types and records. Diagnostic changed (an abbreviation of a function type): Example: @typeOf("string") type cb = int => int Before (diagnostic): @typeOf on a type abbreviation must describe an abstract type, or a type with the same annotation. ... After (diagnostic): This annotation, @typeOf("string"), contradicts the abbreviated type, whose values are recognized by @typeOf("function"). Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- compiler/ml/UntaggedVariants.md | 28 +++-- compiler/ml/includecore.ml | 9 +- compiler/ml/variant_layout.ml | 42 +++---- ...notation_contradicts_function.res.expected | 8 ++ ...otation_interface_over_record.res.expected | 28 +++++ ...untime_annotation_contradicts_function.res | 1 + ...ntime_annotation_interface_over_record.res | 5 + .../src/untagged_runtime_annotations_test.mjs | 119 +++++++++++------- .../src/untagged_runtime_annotations_test.res | 44 +++++++ 9 files changed, 200 insertions(+), 84 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/runtime_annotation_contradicts_function.res.expected create mode 100644 tests/build_tests/super_errors/expected/runtime_annotation_interface_over_record.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/runtime_annotation_contradicts_function.res create mode 100644 tests/build_tests/super_errors/fixtures/runtime_annotation_interface_over_record.res diff --git a/compiler/ml/UntaggedVariants.md b/compiler/ml/UntaggedVariants.md index 68b348a354..126a1988a2 100644 --- a/compiler/ml/UntaggedVariants.md +++ b/compiler/ml/UntaggedVariants.md @@ -108,15 +108,16 @@ into one kind: The builtin types state their kinds in their declarations, as the annotations of rule 5 do for declared types. The shape is read from the type -as written and from each type it abbreviates, and a tuple or a function type -is classified after expanding abbreviations: `type ints = array` is an array case, and `type name = -string` a string case. A type is never recognized by its name. `@typeOf("number")` +as written and from each type it abbreviates, and a tuple, a function type +or a record is classified after expanding abbreviations: `type ints = +array` is an array case, and `type name = string` a string case. Every +reader of rule 5 uses this one classification. A type is never recognized by +its name. `@typeOf("number")` is the number kind, and `@typeOf("symbol")` is a kind of its own, with no builtin payload type. `@notUndefined` on an abstract type leaves it unknown. - Implementation: `predef.ml` (the builtin shapes), - `variant_layout.ml:get_block_type_from_typ`, `get_block_type`, - `recognized_as`. + `variant_layout.ml:payload_kind`, `get_block_type`, `recognized_as`. - Tests: `spec_test` rules 4 (`kinds`, `tuples`, `aliasDict`, `instances`, `unknown`); fixtures `UntaggedConstructorMoreThanOneArg.res`, `UntaggedConstructorAttributeMoreThanOneArg.res`, `UntaggedNonUnary1.res`, @@ -166,8 +167,9 @@ superclass. An annotation on an abbreviation must agree with the abbreviated type. It can refine a type whose representation the compiler does not see, an abstract type that is not builtin and has no annotation, or restate what the -abbreviated type is known to be, as `@typeOf("number") type count = int` and -`@notUndefined type count = int` do; a restating `@notUndefined` keeps the +abbreviated type is known to be (rule 4), as `@typeOf("number") type count = +int`, `@typeOf("function") type callback = int => int` and `@notUndefined +type count = int` do; a restating `@notUndefined` keeps the kind of `int`. The type of a functor parameter, of a recursive module being defined, and a locally abstract type `(type a)` are abstract only where they are declared: they stand for another type, so they @@ -180,9 +182,9 @@ would `type dog = animal` or `type dog = phantom` with | Declaration | Error | Fixture | | --- | --- | --- | -| `@typeOf("string") type t = option`, `type t<'a> = 'a`, an abbreviation of `unit`, `list<_>`, a record or a variant | @typeOf on a type abbreviation must describe an abstract type, ... | `runtime_annotation_on_option.res`, `runtime_annotation_on_type_variable.res` | +| `@typeOf("string") type t = option`, `type t<'a> = 'a`, an abbreviation of `unit`, `list<_>` or a variant | @typeOf on a type abbreviation must describe an abstract type, ... | `runtime_annotation_on_option.res`, `runtime_annotation_on_type_variable.res` | | `@notUndefined type t = option` | @notUndefined on a type abbreviation must describe an abstract type, ... | `not_undefined_on_option.res`, `tests/build_tests/not_undefined_attribute` | -| `@typeOf("number") type t = sym` with `@typeOf("symbol") type sym`, or `@typeOf("string") type t = int` | This annotation, @typeOf("number"), contradicts the abbreviated type, whose values are recognized by @typeOf("symbol"). | `runtime_annotation_contradicts_manifest.res`, `runtime_annotation_contradicts_builtin.res` | +| `@typeOf("number") type t = sym` with `@typeOf("symbol") type sym`, `@typeOf("string") type t = int`, or an abbreviation of a function type or a record | This annotation, @typeOf("number"), contradicts the abbreviated type, whose values are recognized by @typeOf("symbol"). | `runtime_annotation_contradicts_manifest.res`, `runtime_annotation_contradicts_builtin.res`, `runtime_annotation_contradicts_function.res` | | `@instanceOf("Date") type date = X.t` in a functor of `X`, or over `(type a)`; `@notUndefined type t = X.t` | @instanceOf cannot describe the type of a functor parameter, ... | `instance_of_functor_parameter.res`, `type_of_locally_abstract_type.res`, `not_undefined_on_functor_parameter_type.res` | | `@instanceOf("Dog") type dog = animal`, `= animal`, or `= phantom` with `type phantom<'a> = animal` | A subclass must be a private abbreviation ... | `instance_of_public_subclass.res`, `instance_of_public_subclass_instance.res`, `instance_of_public_subclass_through_alias.res` | | `@instanceOf("Animal") type t = private dog` | Animal appears twice in this chain of abbreviations ... | `instance_of_class_twice_in_chain.res` | @@ -192,10 +194,12 @@ would `type dog = animal` or `type dog = phantom` with What an interface states about a type must hold for its implementation. A class or `typeof`, stated through its own annotation or the type it -abbreviates, must be the one the implementation states, superclasses -included: "Their runtime representations differ". A builtin type states its +abbreviates, must be the one the implementation has by rule 4, superclasses +included: "Their runtime representations differ" +(`runtime_annotation_interface_over_record.res`). A builtin type states its kind, so `@typeOf("number") type t` in an interface accepts `type t = int` -(`untagged_builtin_alias_test.res`). Under `@notUndefined`, the +(`untagged_builtin_alias_test.res`), and `@typeOf("function") type t` accepts +`type t = int => int` (`untagged_runtime_annotations_test.res`). Under `@notUndefined`, the implementation must be a type that cannot hold `undefined` either, or one whose representation the compiler does not see, which has none to contradict it: an abstract type, also through an abbreviation such as diff --git a/compiler/ml/includecore.ml b/compiler/ml/includecore.ml index fe6bdee271..5b86154e00 100644 --- a/compiler/ml/includecore.ml +++ b/compiler/ml/includecore.ml @@ -366,12 +366,11 @@ let compare_runtime_annotations env id decl1 decl2 = | Stands_for_another | Can_be_undefined -> [Not_undefined]) | Recognized_as block_type2 -> let declared2 = Some block_type2 in + (* What the first declaration states, or what its structure gives *) let declared1 = - match decl1.type_shape with - | Recognized_as block_type1 -> Some block_type1 - | Never_undefined -> None - | Unstated -> - Option.bind decl1.type_manifest (Variant_layout.recognized_as ~env) + let env = Env.add_type ~check:false id decl1 env in + Variant_layout.payload_kind ~env + (Btype.newgenty (Tconstr (Pident id, decl1.type_params, ref Mnil))) in if declared1 = declared2 then [] else diff --git a/compiler/ml/variant_layout.ml b/compiler/ml/variant_layout.ml index 51b920d2e4..2c1769795d 100644 --- a/compiler/ml/variant_layout.ml +++ b/compiler/ml/variant_layout.ml @@ -33,6 +33,25 @@ let recognized_as ~env t = | Recognized_as block_type -> Some block_type | Unstated | Never_undefined -> None +(* The payload kind of the values of [t]: the one its declarations state, or + the one its structure gives. Builtin types state their kinds in [Predef]; + type expressions other than constructors have no declaration. An unboxed + record is the value of its field, so it has no kind of its own. *) +let payload_kind ~env (t : Types.type_expr) : block_type option = + match recognized_as ~env t with + | Some _ as declared -> declared + | None -> ( + match (Ctype.expand_head env t).desc with + | Ttuple _ -> Some (InstanceType Array) + | Tarrow _ -> Some FunctionType + | Tconstr _ -> ( + match Ctype.extract_concrete_typedecl env t with + | _, _, {type_kind = Type_record (_, Record_unboxed _)} -> None + | _, _, {type_kind = Type_record _} -> Some ObjectType + | _ -> None + | exception Not_found -> None) + | _ -> None) + (* The shape a declaration states, resolved against what the type it abbreviates states in [env]: a class's superclasses are the classes annotated further down a chain of abbreviations. *) @@ -126,7 +145,7 @@ let check_manifest_annotation ~loc ~env (decl : Types.type_declaration) = | None, _ | Some _, None -> () | Some outer, Some manifest -> ( let error err = raise (Error (loc, err)) in - match (outer, recognized_as ~env manifest) with + match (outer, payload_kind ~env manifest) with | _, None -> ( match (Ctype.expand_head_opt env manifest).desc with | Tconstr (path, _, _) -> ( @@ -163,28 +182,9 @@ let check_manifest_annotation ~loc ~env (decl : Types.type_declaration) = ( runtime_annotation_to_string outer, runtime_annotation_to_string (annotation_of_block_type inner) ))) -let get_block_type_from_typ ~env (t : Types.type_expr) : block_type option = - match recognized_as ~env t with - | Some _ as declared -> declared - | None -> ( - (* Builtin types state their shapes in [Predef]; type expressions other - than constructors have no declaration *) - match (Ctype.expand_head env t).desc with - | Ttuple _ -> Some (InstanceType Array) - | Tarrow _ -> Some FunctionType - | _ -> None) - let get_block_type ~env (cstr : Types.constructor_declaration) : block_type = match cstr.cd_args with - | Cstr_tuple [ty] -> ( - match get_block_type_from_typ ~env ty with - | Some shape -> shape - | None -> ( - match Ctype.extract_concrete_typedecl env ty with - | _, _, {type_kind = Type_record (_, Record_unboxed _)} -> UnknownType - | _, _, {type_kind = Type_record (_, _)} -> ObjectType - | _ -> UnknownType - | exception _ -> UnknownType)) + | Cstr_tuple [ty] -> Option.value (payload_kind ~env ty) ~default:UnknownType | Cstr_tuple (_ :: _ :: _) -> report_constructor_more_than_one_arg ~loc:cstr.cd_loc ~name:(Ident.name cstr.cd_id) diff --git a/tests/build_tests/super_errors/expected/runtime_annotation_contradicts_function.res.expected b/tests/build_tests/super_errors/expected/runtime_annotation_contradicts_function.res.expected new file mode 100644 index 0000000000..edd0d1c6dd --- /dev/null +++ b/tests/build_tests/super_errors/expected/runtime_annotation_contradicts_function.res.expected @@ -0,0 +1,8 @@ + + We've found a bug for you! + /.../fixtures/runtime_annotation_contradicts_function.res:1:19-38 + + 1 │ @typeOf("string") type cb = int => int + 2 │ + + This annotation, @typeOf("string"), contradicts the abbreviated type, whose values are recognized by @typeOf("function"). \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/runtime_annotation_interface_over_record.res.expected b/tests/build_tests/super_errors/expected/runtime_annotation_interface_over_record.res.expected new file mode 100644 index 0000000000..2bf2b45201 --- /dev/null +++ b/tests/build_tests/super_errors/expected/runtime_annotation_interface_over_record.res.expected @@ -0,0 +1,28 @@ + + We've found a bug for you! + /.../fixtures/runtime_annotation_interface_over_record.res:3:5-5:1 + + 1 │ module M: { + 2 │ @typeOf("string") type t + 3 │ } = { + 4 │  type t = {y: int} + 5 │ } + 6 │ + + Signature mismatch: + Modules do not match: + { + type t = {y: int} +} + is not included in + { + type t +} + Type declarations do not match: type t = {y: int} is not included in type t + /.../fixtures/runtime_annotation_interface_over_record.res:2:21-26: + Expected declaration + /.../fixtures/runtime_annotation_interface_over_record.res:4:3-19: + Actual declaration + Their runtime representations differ: + the first declaration states values whose typeof is "object", + the second declaration states values whose typeof is "string". \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/runtime_annotation_contradicts_function.res b/tests/build_tests/super_errors/fixtures/runtime_annotation_contradicts_function.res new file mode 100644 index 0000000000..86a148bd4e --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/runtime_annotation_contradicts_function.res @@ -0,0 +1 @@ +@typeOf("string") type cb = int => int diff --git a/tests/build_tests/super_errors/fixtures/runtime_annotation_interface_over_record.res b/tests/build_tests/super_errors/fixtures/runtime_annotation_interface_over_record.res new file mode 100644 index 0000000000..5d079ed164 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/runtime_annotation_interface_over_record.res @@ -0,0 +1,5 @@ +module M: { + @typeOf("string") type t +} = { + type t = {y: int} +} diff --git a/tests/tests/src/untagged_runtime_annotations_test.mjs b/tests/tests/src/untagged_runtime_annotations_test.mjs index 9e80734b94..bccd06f8a1 100644 --- a/tests/tests/src/untagged_runtime_annotations_test.mjs +++ b/tests/tests/src/untagged_runtime_annotations_test.mjs @@ -86,21 +86,42 @@ function handlerKind(handler) { } } -function wideHandlerKind(handler) { - if (typeof handler === "string") { - return "name"; - } else if (typeof handler === "function" && !(handler instanceof UntaggedAnimal) && !(handler instanceof UntaggedCallable)) { - return "function"; +function objectOrNameKind(value) { + if (typeof value === "string") { + return value; } else { - return "other"; + return "dog"; } } -function objectOrNameKind(value) { +function callback(x) { + return x + 1 | 0; +} + +let point = { + py: 1 +}; + +let Restated = { + callback: callback, + point: point +}; + +function restatedKind(value) { if (typeof value === "string") { return value; + } else if (typeof value === "function") { + return value(1).toString(); } else { - return "dog"; + return value.px.toString(); + } +} + +function restatedAbstractKind(value) { + if (typeof value === "function") { + return "callback"; + } else { + return "point"; } } @@ -147,75 +168,79 @@ function sharedKind(value) { Mocha.describe("Untagged_runtime_annotations_test", () => { Mocha.test("a subclass case is not taken for its superclass", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 199, characters 7-14", "animal", describePet(new UntaggedAnimal())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 200, characters 7-14", "dog", describePet(new UntaggedDog())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 201, characters 7-14", "rex", "rex"); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 218, characters 7-14", "animal", describePet(new UntaggedAnimal())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 219, characters 7-14", "dog", describePet(new UntaggedDog())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 220, characters 7-14", "rex", "rex"); }); Mocha.test("a superclass case alone excludes the subclass", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 205, characters 7-14", "animal", onlyAnimal(new UntaggedAnimal())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 206, characters 7-14", "other", onlyAnimal(new UntaggedDog())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 224, characters 7-14", "animal", onlyAnimal(new UntaggedAnimal())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 225, characters 7-14", "other", onlyAnimal(new UntaggedDog())); }); Mocha.test("declaration order does not matter", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 210, characters 7-14", "dog", describeReversed(new UntaggedDog())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 211, characters 7-14", "animal", describeReversed(new UntaggedAnimal())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 229, characters 7-14", "dog", describeReversed(new UntaggedDog())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 230, characters 7-14", "animal", describeReversed(new UntaggedAnimal())); }); Mocha.test("a subclass upcasts to its superclass", () => { let animal = new UntaggedDog(); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 216, characters 7-14", "dog", describePet(animal)); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 235, characters 7-14", "dog", describePet(animal)); }); Mocha.test("classes reached through a module alias", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 220, characters 7-14", "animal", describeAliased(new UntaggedAnimal())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 221, characters 7-14", "dog", describeAliased(new UntaggedDog())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 239, characters 7-14", "animal", describeAliased(new UntaggedAnimal())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 240, characters 7-14", "dog", describeAliased(new UntaggedDog())); }); Mocha.test("typeOf symbol", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 225, characters 7-14", "symbol", keyKind(Symbol.for("key"))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 226, characters 7-14", "text", "text"); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 244, characters 7-14", "symbol", keyKind(Symbol.for("key"))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 245, characters 7-14", "text", "text"); }); Mocha.test("typeOf string", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 230, characters 7-14", "id", "id"); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 231, characters 7-14", "index", "index"); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 249, characters 7-14", "id", "id"); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 250, characters 7-14", "index", "index"); }); Mocha.test("a class at a dotted path", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 235, characters 7-14", "locale", localeKind(new Intl.Locale("en"))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 236, characters 7-14", "de", "de"); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 254, characters 7-14", "locale", localeKind(new Intl.Locale("en"))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 255, characters 7-14", "de", "de"); }); Mocha.test("an annotated type is not wrapped in an option", () => { let animal = new UntaggedAnimal(); - Test_utils.ok("File \"untagged_runtime_annotations_test.res\", line 241, characters 7-14", animal === animal); - Test_utils.ok("File \"untagged_runtime_annotations_test.res\", line 242, characters 7-14", animal === animal); + Test_utils.ok("File \"untagged_runtime_annotations_test.res\", line 260, characters 7-14", animal === animal); + Test_utils.ok("File \"untagged_runtime_annotations_test.res\", line 261, characters 7-14", animal === animal); }); Mocha.test("a phantom type hierarchy", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 246, characters 7-14", "animal", describePhantom(new UntaggedAnimal())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 247, characters 7-14", "dog", describePhantom(new UntaggedDog())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 265, characters 7-14", "animal", describePhantom(new UntaggedAnimal())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 266, characters 7-14", "dog", describePhantom(new UntaggedDog())); }); Mocha.test("a function case excludes class instances", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 251, characters 7-14", "callable", handlerKind(new UntaggedCallable())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 252, characters 7-14", "function", handlerKind(x => x)); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 253, characters 7-14", "other", wideHandlerKind(new UntaggedCallable())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 254, characters 7-14", "other", wideHandlerKind(new UntaggedAnimal())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 255, characters 7-14", "function", wideHandlerKind(x => x)); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 256, characters 7-14", "name", "name"); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 257, characters 7-14", "other", "other"); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 270, characters 7-14", "callable", handlerKind(new UntaggedCallable())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 271, characters 7-14", "function", handlerKind(x => x)); }); Mocha.test("a class declared over an object type", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 261, characters 7-14", "dog", objectOrNameKind(new UntaggedDog())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 262, characters 7-14", "rex", "rex"); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 275, characters 7-14", "dog", objectOrNameKind(new UntaggedDog())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 276, characters 7-14", "rex", "rex"); + }); + Mocha.test("annotations restating a structural kind", () => { + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 280, characters 7-14", "2", restatedKind(id(x => x + 1 | 0))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 281, characters 7-14", "3", restatedKind(id({ + px: 3 + }))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 282, characters 7-14", "a", restatedKind(id("a"))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 283, characters 7-14", "callback", restatedAbstractKind(id(callback))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 284, characters 7-14", "point", restatedAbstractKind(id(point))); }); Mocha.test("primitive cases are tested before class checks", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 266, characters 7-14", "a", missingKind(id("a"))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 267, characters 7-14", "count", missingKind(id(1))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 288, characters 7-14", "a", missingKind(id("a"))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 289, characters 7-14", "count", missingKind(id(1))); }); Mocha.test("a primitive without an arm skips class checks", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 271, characters 7-14", "a", missingOrDefault(id("a"))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 272, characters 7-14", "other", missingOrDefault(id(1))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 293, characters 7-14", "a", missingOrDefault(id("a"))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 294, characters 7-14", "other", missingOrDefault(id(1))); }); Mocha.test("a default shared by a primitive and an object case", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 276, characters 7-14", "date!", sharedKind(id(new Date()))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 277, characters 7-14", "other!", sharedKind(id({ + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 298, characters 7-14", "date!", sharedKind(id(new Date()))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 299, characters 7-14", "other!", sharedKind(id({ x: 1 }))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 278, characters 7-14", "text!", sharedKind(id("a"))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 279, characters 7-14", "other!", sharedKind(id(1))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 300, characters 7-14", "text!", sharedKind(id("a"))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 301, characters 7-14", "other!", sharedKind(id(1))); }); }); @@ -233,8 +258,10 @@ export { localeKind, describePhantom, handlerKind, - wideHandlerKind, objectOrNameKind, + Restated, + restatedKind, + restatedAbstractKind, id, missingKind, missingOrDefault, diff --git a/tests/tests/src/untagged_runtime_annotations_test.res b/tests/tests/src/untagged_runtime_annotations_test.res index 062bf85fca..15f3bd38f5 100644 --- a/tests/tests/src/untagged_runtime_annotations_test.res +++ b/tests/tests/src/untagged_runtime_annotations_test.res @@ -160,6 +160,42 @@ let objectOrNameKind = value => | ObjectName(name) => name } +// Annotations restating the kind a type's structure gives +@typeOf("function") type callback = int => int +type point = {px: int} +@typeOf("object") type pointObject = point + +module Restated: { + @typeOf("function") type callback + @typeOf("object") type point + let callback: callback + let point: point +} = { + type callback = int => int + type point = {py: int} + let callback = x => x + 1 + let point = {py: 1} +} + +@unboxed +type restated = Callback(callback) | PointObject(pointObject) | Label(string) + +let restatedKind = value => + switch value { + | Callback(callback) => Int.toString(callback(1)) + | PointObject(point) => Int.toString(point.px) + | Label(label) => label + } + +@unboxed +type restatedAbstract = AbstractCallback(Restated.callback) | AbstractPoint(Restated.point) + +let restatedAbstractKind = value => + switch value { + | AbstractCallback(_) => "callback" + | AbstractPoint(_) => "point" + } + @inline(never) let id = x => x // No class of this name exists at run time @@ -262,6 +298,14 @@ describe(__MODULE__, () => { eq(__LOC__, "rex", objectOrNameKind(ObjectName("rex"))) }) + test("annotations restating a structural kind", () => { + eq(__LOC__, "2", restatedKind(id(Callback(x => x + 1)))) + eq(__LOC__, "3", restatedKind(id(PointObject({px: 3})))) + eq(__LOC__, "a", restatedKind(id(Label("a")))) + eq(__LOC__, "callback", restatedAbstractKind(id(AbstractCallback(Restated.callback)))) + eq(__LOC__, "point", restatedAbstractKind(id(AbstractPoint(Restated.point)))) + }) + test("primitive cases are tested before class checks", () => { eq(__LOC__, "a", missingKind(id(Text("a")))) eq(__LOC__, "count", missingKind(id(Count(1.)))) From 50e1ecb64937851254a6b27604c58656d9aa505a Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sun, 25 Oct 2026 14:09:09 +0000 Subject: [PATCH 10/13] Read the three runtime annotations on one path Why: `@notUndefined` was parsed, checked on declarations and checked on abbreviations apart from `@instanceOf` and `@typeOf`, so each step had two versions, and a type could carry it beside the others. `process_runtime_annotation` returns `Not_undefined` as well, so one parse feeds `declaration_shape`, the check for represented types and `Typedecl.check_manifest_annotation`, which now checks all three on an abbreviation. `Typeopt.abstractness` takes a type and is what `undefinedness` falls back to. Diagnostic changed (two of the three annotations): Example: @notUndefined @typeOf("string") type t Before (diagnostic): none After (diagnostic): A type can have only one of @notUndefined, @instanceOf and @typeOf. @instanceOf and @typeOf already imply @notUndefined. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- compiler/ml/UntaggedVariants.md | 12 +-- compiler/ml/ast_untagged_variants.ml | 23 +++-- compiler/ml/typedecl.ml | 92 +++++++++++++------ compiler/ml/typeopt.ml | 42 ++++++--- compiler/ml/typeopt.mli | 7 ++ compiler/ml/variant_layout.ml | 86 ++--------------- .../runtime_annotation_conflict.res.expected | 2 +- ...tation_not_undefined_conflict.res.expected | 8 ++ ...time_annotation_not_undefined_conflict.res | 1 + 9 files changed, 136 insertions(+), 137 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/runtime_annotation_not_undefined_conflict.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/runtime_annotation_not_undefined_conflict.res diff --git a/compiler/ml/UntaggedVariants.md b/compiler/ml/UntaggedVariants.md index 126a1988a2..ee03b23c03 100644 --- a/compiler/ml/UntaggedVariants.md +++ b/compiler/ml/UntaggedVariants.md @@ -139,8 +139,8 @@ level implying the one before: - `@instanceOf("C")`: they are instances of the global class at the path `C`, such as `"Date"` or `"Intl.Locale"`. -A type has at most one of `@typeOf` and `@instanceOf`, and only abstract types -and type abbreviations, public or private, can have any of the three. +A type has at most one of the three, and only abstract types and type +abbreviations, public or private, can have one. `@notUndefined` affects only rule 12: `option` of the type, and of an untagged variant with a payload of the type, is unboxed. It does not make the type a recognized payload kind (rule 4). @@ -189,7 +189,7 @@ would `type dog = animal` or `type dog = phantom` with | `@instanceOf("Dog") type dog = animal`, `= animal`, or `= phantom` with `type phantom<'a> = animal` | A subclass must be a private abbreviation ... | `instance_of_public_subclass.res`, `instance_of_public_subclass_instance.res`, `instance_of_public_subclass_through_alias.res` | | `@instanceOf("Animal") type t = private dog` | Animal appears twice in this chain of abbreviations ... | `instance_of_class_twice_in_chain.res` | | any of the three on a record or variant | @instanceOf can only be used on abstract types and type abbreviations ... | `runtime_annotation_on_record.res`, `invalid_attribute_not_undefined.res` | -| both `@instanceOf` and `@typeOf` | A type can have either @instanceOf or @typeOf, not both. | `runtime_annotation_conflict.res` | +| two of the three | A type can have only one of @notUndefined, @instanceOf and @typeOf. ... | `runtime_annotation_conflict.res`, `runtime_annotation_not_undefined_conflict.res` | | one annotation twice | Duplicate @instanceOf annotation; a type can have only one. | `instance_of_duplicate.res` | What an interface states about a type must hold for its implementation. A @@ -249,9 +249,9 @@ written (Known bugs). - Implementation: `types.mli:type_shape`, `variant_runtime.mli:value_shape`; `variant_layout.ml:declaration_shape`, - `resolve_shapes`, `value_shape`, `check_manifest_annotation`; - `typedecl.ml:check_manifest_annotations`; `typeopt.ml:undefinedness`; - `ast_untagged_variants.ml:process_runtime_annotation`, `has_not_undefined`, + `resolve_shapes`, `value_shape`, `payload_kind`; + `typedecl.ml:check_manifest_annotation`; `typeopt.ml:abstractness`, + `undefinedness`; `ast_untagged_variants.ml:process_runtime_annotation`, `unsupported_class`, `check_runtime_annotation`; `includecore.ml:compare_runtime_annotations`; `variant_runtime.ml:Instance`; `js_exp_make.ml:class_constructor`. diff --git a/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml index 398ac084ed..dbebfa3054 100644 --- a/compiler/ml/ast_untagged_variants.ml +++ b/compiler/ml/ast_untagged_variants.ml @@ -148,7 +148,9 @@ let report_error ppf = for another one, whose values can be anything." attribute | ConflictingRuntimeAnnotations -> - fprintf ppf "A type can have either @instanceOf or @typeOf, not both." + fprintf ppf + "A type can have only one of @notUndefined, @instanceOf and @typeOf. \ + @instanceOf and @typeOf already imply @notUndefined." | RuntimeAnnotationOnRepresentedType attribute -> fprintf ppf "@%s can only be used on abstract types and type abbreviations, whose \ @@ -242,12 +244,14 @@ let report_constructor_more_than_one_arg ~loc ~name = (Error (loc, InvalidUntaggedVariantDefinition (ConstructorMoreThanOneArg name))) -(* What [@instanceOf] or [@typeOf] on a type declaration states about the - runtime representation of its values. *) +(* What [@notUndefined], [@instanceOf] or [@typeOf] on a type declaration + states about the runtime representation of its values. *) type runtime_annotation = + | Not_undefined (** values that are never [undefined] *) | Instance_of of string (** instances of the global class at this path *) | Type_of of block_type (** values with this [typeof] *) +let not_undefined = "notUndefined" let instance_of = "instanceOf" let type_of = "typeOf" @@ -294,6 +298,7 @@ let is_class_path name = | [] -> false let runtime_attribute_name = function + | Not_undefined -> not_undefined | Instance_of _ -> instance_of | Type_of _ -> type_of @@ -302,6 +307,7 @@ let typeof_name block_type = Option.value (Variant_runtime.typeof_name block_type) ~default:"object" let runtime_annotation_to_string = function + | Not_undefined -> "@" ^ not_undefined | Instance_of name -> Printf.sprintf "@%s(\"%s\")" instance_of name | Type_of block_type -> Printf.sprintf "@%s(\"%s\")" type_of (typeof_name block_type) @@ -317,16 +323,15 @@ let describe_declared_block_type = function "values whose typeof is \"" ^ typeof_name block_type ^ "\"" | None -> "no runtime class or typeof" -let has_not_undefined (attrs : Parsetree.attributes) = - Ext_list.exists attrs (fun ({txt}, _) -> txt = "notUndefined") - -(* The [@instanceOf] or [@typeOf] annotation in [attrs], validated. Only - [Typedecl] passes [~loc]; later readers see attributes it accepted. *) +(* The [@notUndefined], [@instanceOf] or [@typeOf] annotation in [attrs], + validated. Only [Typedecl] passes [~loc]; later readers see attributes it + accepted. *) let process_runtime_annotation ?(loc = Location.none) (attrs : Parsetree.attributes) = let annotation_of ({Location.txt; loc = attr_loc}, payload) = let loc = if attr_loc = Location.none then loc else attr_loc in - if txt = instance_of then + if txt = not_undefined then Some Not_undefined + else if txt = instance_of then match Ast_payload.semantic_string_of_payload payload with | Some name when is_class_path name -> ( match unsupported_class name with diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index aed16933fc..0fa8da5d7d 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -336,35 +336,69 @@ let make_constructor env type_path type_params sargs sret_type = any type variable present in [ty]. *) -(* [@notUndefined] on an abbreviation is a claim about the abbreviated type, - as [@instanceOf] and [@typeOf] are: it can refine a type whose - representation the compiler does not see, or restate that a type cannot - hold [undefined] *) -let check_not_undefined_manifest ~loc ~env (decl : Types.type_declaration) = - match decl.type_manifest with - | Some manifest - when Ast_untagged_variants.has_not_undefined decl.type_attributes -> ( - let error err = raise (Ast_untagged_variants.Error (loc, err)) in - match Typeopt.undefinedness env manifest with - | Cannot_be_undefined | Unseen -> () - | Stands_for_another -> - error (RuntimeAnnotationOnTypeParameter "notUndefined") - | Can_be_undefined -> - error (RuntimeAnnotationOnUnrelatedType "notUndefined")) - | Some _ | None -> () - -let check_manifest_annotations ~loc ~env decl = - Variant_layout.check_manifest_annotation ~loc ~env decl; - check_not_undefined_manifest ~loc ~env decl +(* An annotation on an abbreviation is a claim about the abbreviated type, so + it must agree with what the compiler knows about that type. It can refine + an abstract type, restate what the abbreviated type is known to be, or, on + a private abbreviation, declare a subclass of the class annotated there. + Anything else, such as [@typeOf("string") type t = option], would + let two spellings of one type be recognized differently, and would make + [Some(None)] of a type that can be undefined indistinguishable from + [None]. *) +let check_manifest_annotation ~loc ~env (decl : Types.type_declaration) = + let open Ast_untagged_variants in + let open Variant_runtime in + match + (process_runtime_annotation decl.type_attributes, decl.type_manifest) + with + | None, _ | Some _, None -> () + | Some outer, Some manifest -> ( + let error err = raise (Error (loc, err)) in + let stands_for_another () = + error (RuntimeAnnotationOnTypeParameter (runtime_attribute_name outer)) + in + let unrelated () = + error (RuntimeAnnotationOnUnrelatedType (runtime_attribute_name outer)) + in + match (outer, Variant_layout.payload_kind ~env manifest) with + | Not_undefined, _ -> ( + match Typeopt.undefinedness env manifest with + | Cannot_be_undefined | Unseen -> () + | Stands_for_another -> stands_for_another () + | Can_be_undefined -> unrelated ()) + | (Instance_of _ | Type_of _), None -> ( + match Typeopt.abstractness env manifest with + | Opaque -> () + | Stands_for_another -> stands_for_another () + | Not_abstract -> unrelated ()) + | Type_of block_type, Some inner when block_type = inner -> () + | Instance_of name, Some (InstanceType (Class {name = inner})) + when name = inner -> + () + | Instance_of name, Some ((InstanceType (Class _) | ObjectType) as inner) -> + (* A public abbreviation would make every value of the superclass type + a value of the subclass, without a coercion *) + let superclass, ancestors = + match inner with + | InstanceType (Class {name = ancestor; ancestors}) -> + (ancestor, ancestor :: ancestors) + (* Every class instance is an object *) + | _ -> ("Object", []) + in + if decl.type_private = Public then + error (SubclassOfPublicAbbreviation (name, superclass)) + else if List.mem name ancestors then error (ClassTwiceInChain name) + | (Instance_of _ | Type_of _), Some inner -> + let inner = + match inner with + | InstanceType (Class {name}) -> Instance_of name + | block_type -> Type_of block_type + in + error + (RuntimeAnnotationContradictsManifest + ( runtime_annotation_to_string outer, + runtime_annotation_to_string inner ))) let transl_declaration ~type_record_as_object env sdecl id = - if - Ast_untagged_variants.has_not_undefined sdecl.ptype_attributes - && sdecl.ptype_kind <> Ptype_abstract - then - raise - (Ast_untagged_variants.Error - (sdecl.ptype_loc, RuntimeAnnotationOnRepresentedType "notUndefined")); Ast_untagged_variants.check_runtime_annotation ~loc:sdecl.ptype_loc ~is_abstract_or_abbreviation:(sdecl.ptype_kind = Ptype_abstract) sdecl.ptype_attributes; @@ -1605,7 +1639,7 @@ let transl_type_decl env rec_flag sdecl_list = in List.iter2 (fun sdecl (_, decl) -> - check_manifest_annotations ~loc:sdecl.ptype_loc ~env:newenv decl) + check_manifest_annotation ~loc:sdecl.ptype_loc ~env:newenv decl) sdecl_list decls; List.iter2 (check_constraints ~type_record_as_object newenv) sdecl_list decls; (* Name recursion *) @@ -2018,7 +2052,7 @@ let transl_with_constraint env id row_path orig_decl sdecl = let decl = {decl with type_shape = Variant_layout.declaration_shape ~env decl} in - check_manifest_annotations ~loc:sdecl.ptype_loc ~env decl; + check_manifest_annotation ~loc:sdecl.ptype_loc ~env decl; let decl = name_recursion sdecl id decl in let type_variance = compute_variance_decl env true decl diff --git a/compiler/ml/typeopt.ml b/compiler/ml/typeopt.ml index 4d2be412ed..35ef4d6661 100644 --- a/compiler/ml/typeopt.ml +++ b/compiler/ml/typeopt.ml @@ -122,6 +122,26 @@ let rec cannot_contain_undefined ~visiting (typ : Types.type_expr) (env : Env.t) let type_cannot_contain_undefined typ env = cannot_contain_undefined ~visiting:[] typ env +type abstractness = Opaque | Stands_for_another | Not_abstract + +(* Whether [ty] is, also through abbreviations, an abstract type with a + representation of its own, which an annotation can refine, or one that + stands for another type: a functor parameter's type, a recursive module's + type being defined, or a locally abstract type. *) +let abstractness env ty = + match (Ctype.expand_head_opt env ty).desc with + | Tconstr (path, _, _) -> ( + match Env.find_type path env with + | {type_kind = Type_abstract; type_manifest = None; type_newtype_level} -> + if type_newtype_level <> None || Env.is_functor_arg path env then + Stands_for_another + else if Predef.type_is_builtin_path_but_option path <> Predef.NA then + Not_abstract + else Opaque + | _ -> Not_abstract + | exception Not_found -> Not_abstract) + | _ -> Not_abstract + type undefinedness = | Cannot_be_undefined | Unseen @@ -129,20 +149,18 @@ type undefinedness = | Can_be_undefined (* Whether a type can hold [undefined], as far as the compiler sees. An - abstract type, also through an abbreviation, or a JavaScript object type - has a representation the compiler does not see; a functor parameter's or a - locally abstract type stands for any type. *) -let undefinedness env ty = + opaque abstract type or a JavaScript object type has a representation the + compiler does not see. *) +let undefinedness env ty : undefinedness = if type_cannot_contain_undefined ty env then Cannot_be_undefined else - match (Ctype.expand_head_opt env ty).desc with - | Tconstr (path, _, _) -> ( - match Variant_layout.abstractness ~env path with - | Opaque -> Unseen - | Stands_for_another -> Stands_for_another - | Not_abstract -> Can_be_undefined) - | Tobject _ -> Unseen - | _ -> Can_be_undefined + match abstractness env ty with + | Opaque -> Unseen + | Stands_for_another -> Stands_for_another + | Not_abstract -> ( + match (Ctype.expand_head_opt env ty).desc with + | Tobject _ -> Unseen + | _ -> Can_be_undefined) let is_function_type env ty = match scrape env ty with diff --git a/compiler/ml/typeopt.mli b/compiler/ml/typeopt.mli index 4bafce4bf7..c46aa5da12 100644 --- a/compiler/ml/typeopt.mli +++ b/compiler/ml/typeopt.mli @@ -23,6 +23,13 @@ val maybe_pointer_type : Env.t -> Types.type_expr -> Lambda.immediate_or_pointer val type_cannot_contain_undefined : Types.type_expr -> Env.t -> bool +(** Whether a type is an abstract type whose representation the compiler + does not see, one that stands for another type (a functor parameter's or + a locally abstract type), or neither *) +type abstractness = Opaque | Stands_for_another | Not_abstract + +val abstractness : Env.t -> Types.type_expr -> abstractness + (** Whether a type can hold [undefined]: it cannot, the compiler does not see its representation, it stands for another type (a functor parameter's or a locally abstract type), or it can *) diff --git a/compiler/ml/variant_layout.ml b/compiler/ml/variant_layout.ml index 2c1769795d..57a5311025 100644 --- a/compiler/ml/variant_layout.ml +++ b/compiler/ml/variant_layout.ml @@ -57,6 +57,7 @@ let payload_kind ~env (t : Types.type_expr) : block_type option = annotated further down a chain of abbreviations. *) let declaration_shape ~env (decl : Types.type_declaration) : value_shape = match process_runtime_annotation decl.type_attributes with + | None -> Unstated | Some (Type_of block_type) -> Recognized_as block_type | Some (Instance_of name) -> let ancestors = @@ -68,13 +69,11 @@ let declaration_shape ~env (decl : Types.type_declaration) : value_shape = | Some _ | None -> [] in Recognized_as (InstanceType (Class {name; ancestors})) - | None -> ( - if not (has_not_undefined decl.type_attributes) then Unstated - else - (* Restating a kind the abbreviated type is recognized by keeps it *) - match Option.map (value_shape ~env) decl.type_manifest with - | Some (Recognized_as _ as shape) -> shape - | Some (Unstated | Never_undefined) | None -> Never_undefined) + | Some Not_undefined -> ( + (* Restating a kind the abbreviated type is recognized by keeps it *) + match Option.map (value_shape ~env) decl.type_manifest with + | Some (Recognized_as _ as shape) -> shape + | Some (Unstated | Never_undefined) | None -> Never_undefined) (* Resolves the shapes of a group of declarations, which can abbreviate each other. Each round resolves one more level of abbreviation within the @@ -109,79 +108,6 @@ let resolve_shapes ~env (decls : (Ident.t * Types.type_declaration) list) = in round env decls (List.length decls) -(* Whether the abstract type at [path] has a representation of its own, which - an annotation can refine, or stands for another type: a functor - parameter's type, a recursive module's type being defined, or a locally - abstract type. *) -type abstractness = Opaque | Stands_for_another | Not_abstract - -let abstractness ~env path = - match Env.find_type path env with - | {type_kind = Type_abstract; type_manifest = None; type_newtype_level} -> - if type_newtype_level <> None || Env.is_functor_arg path env then - Stands_for_another - else if Predef.type_is_builtin_path_but_option path <> Predef.NA then - Not_abstract - else Opaque - | _ -> Not_abstract - | exception Not_found -> Not_abstract - -let annotation_of_block_type = function - | InstanceType (Class {name}) -> Instance_of name - | block_type -> Type_of block_type - -(* An annotation on an abbreviation is a claim about the abbreviated type, so - it must agree with what the compiler knows about that type. It can refine - an abstract type, restate the annotation the abbreviated type has, or, on a - private abbreviation, declare a subclass of the class annotated there. - Anything else, such as [@typeOf("string") type t = option], would - let two spellings of one type be recognized differently, and would make - [Some(None)] of a type that can be undefined indistinguishable from - [None]. *) -let check_manifest_annotation ~loc ~env (decl : Types.type_declaration) = - match - (process_runtime_annotation decl.type_attributes, decl.type_manifest) - with - | None, _ | Some _, None -> () - | Some outer, Some manifest -> ( - let error err = raise (Error (loc, err)) in - match (outer, payload_kind ~env manifest) with - | _, None -> ( - match (Ctype.expand_head_opt env manifest).desc with - | Tconstr (path, _, _) -> ( - match abstractness ~env path with - | Opaque -> () - | Stands_for_another -> - error - (RuntimeAnnotationOnTypeParameter (runtime_attribute_name outer)) - | Not_abstract -> - error - (RuntimeAnnotationOnUnrelatedType (runtime_attribute_name outer))) - | _ -> - error (RuntimeAnnotationOnUnrelatedType (runtime_attribute_name outer))) - | Type_of block_type, Some inner when block_type = inner -> () - | Instance_of name, Some (InstanceType (Class {name = inner})) - when name = inner -> - () - | Instance_of name, Some ((InstanceType (Class _) | ObjectType) as inner) -> - (* A public abbreviation would make every value of the superclass type - a value of the subclass, without a coercion *) - let superclass, ancestors = - match inner with - | InstanceType (Class {name = ancestor; ancestors}) -> - (ancestor, ancestor :: ancestors) - (* Every class instance is an object *) - | _ -> ("Object", []) - in - if decl.type_private = Public then - error (SubclassOfPublicAbbreviation (name, superclass)) - else if List.mem name ancestors then error (ClassTwiceInChain name) - | (Instance_of _ | Type_of _), Some inner -> - error - (RuntimeAnnotationContradictsManifest - ( runtime_annotation_to_string outer, - runtime_annotation_to_string (annotation_of_block_type inner) ))) - let get_block_type ~env (cstr : Types.constructor_declaration) : block_type = match cstr.cd_args with | Cstr_tuple [ty] -> Option.value (payload_kind ~env ty) ~default:UnknownType diff --git a/tests/build_tests/super_errors/expected/runtime_annotation_conflict.res.expected b/tests/build_tests/super_errors/expected/runtime_annotation_conflict.res.expected index 1283d8bc21..d6758b65a5 100644 --- a/tests/build_tests/super_errors/expected/runtime_annotation_conflict.res.expected +++ b/tests/build_tests/super_errors/expected/runtime_annotation_conflict.res.expected @@ -5,4 +5,4 @@ 1 │ @instanceOf("Date") @typeOf("object") type t 2 │ - A type can have either @instanceOf or @typeOf, not both. \ No newline at end of file + A type can have only one of @notUndefined, @instanceOf and @typeOf. @instanceOf and @typeOf already imply @notUndefined. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/runtime_annotation_not_undefined_conflict.res.expected b/tests/build_tests/super_errors/expected/runtime_annotation_not_undefined_conflict.res.expected new file mode 100644 index 0000000000..35123850bd --- /dev/null +++ b/tests/build_tests/super_errors/expected/runtime_annotation_not_undefined_conflict.res.expected @@ -0,0 +1,8 @@ + + We've found a bug for you! + /.../fixtures/runtime_annotation_not_undefined_conflict.res:1:33-38 + + 1 │ @notUndefined @typeOf("string") type t + 2 │ + + A type can have only one of @notUndefined, @instanceOf and @typeOf. @instanceOf and @typeOf already imply @notUndefined. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/runtime_annotation_not_undefined_conflict.res b/tests/build_tests/super_errors/fixtures/runtime_annotation_not_undefined_conflict.res new file mode 100644 index 0000000000..2eac10d8a2 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/runtime_annotation_not_undefined_conflict.res @@ -0,0 +1 @@ +@notUndefined @typeOf("string") type t From 33b9f36b78bd87fefe236b7c2f0347e108805807 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sun, 25 Oct 2026 14:11:11 +0000 Subject: [PATCH 11/13] Count untagged payload kinds in one table Why: `check_invariant` kept a counter per payload kind and rechecked all of them after every case, with an error variant per kind. The kinds seen so far are one table, classes keyed by name, and a second case of a kind is reported where it is added. `AtMostOneOfKind` replaces the eight `AtMostOne*` errors and keeps their messages. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- compiler/ml/ast_untagged_variants.ml | 35 ++++------ compiler/ml/variant_layout.ml | 101 +++++++++------------------ 2 files changed, 49 insertions(+), 87 deletions(-) diff --git a/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml index dbebfa3054..2fbb12ade3 100644 --- a/compiler/ml/ast_untagged_variants.ml +++ b/compiler/ml/ast_untagged_variants.ml @@ -2,14 +2,7 @@ open Variant_runtime type untagged_error = | OnlyOneUnknown of string - | AtMostOneObject - | AtMostOneInstance of Instance.t - | AtMostOneFunction - | AtMostOneString - | AtMostOneNumber - | AtMostOneBigint - | AtMostOneBoolean - | AtMostOneSymbol + | AtMostOneOfKind of block_type (** never [UnknownType] *) | UnreachableBoolean of string | DuplicateLiteral of string | SameLiteralValue of string * string @@ -66,22 +59,24 @@ let report_error ppf = "Case " ^ name ^ " has a payload that is not of one of the recognized shapes (object, \ array, etc). Then it must be the only case with payloads." - | AtMostOneObject -> "At most one case can be an object type." - | AtMostOneInstance Array -> - "At most one case can be an array or tuple type." - | AtMostOneInstance i -> - "At most one case can be an instance of " ^ Instance.to_string i ^ "." - | AtMostOneFunction -> "At most one case can be a function type." - | AtMostOneString -> "At most one case can be a string type." - | AtMostOneBoolean -> "At most one case can be a boolean type." - | AtMostOneSymbol -> "At most one case can be a symbol type." + | AtMostOneOfKind kind -> + "At most one case can be " + ^ (match kind with + | ObjectType -> "an object type" + | InstanceType Array -> "an array or tuple type" + | InstanceType i -> "an instance of " ^ Instance.to_string i + | FunctionType -> "a function type" + | StringType -> "a string type" + | NumberType -> "a number type (int or float)" + | BigintType -> "a bigint type" + | BooleanType -> "a boolean type" + | SymbolType -> "a symbol type" + | UnknownType -> "of an unknown type") + ^ "." | UnreachableBoolean name -> "Case " ^ name ^ " can never match: both true and false are already cases of this \ variant." - | AtMostOneNumber -> - "At most one case can be a number type (int or float)." - | AtMostOneBigint -> "At most one case can be a bigint type." | DuplicateLiteral s -> "Duplicate literal " ^ s ^ "." | SameLiteralValue (literal, earlier) -> "The literal " ^ literal ^ " is the same JavaScript value as " ^ earlier diff --git a/compiler/ml/variant_layout.ml b/compiler/ml/variant_layout.ml index 57a5311025..12300c4725 100644 --- a/compiler/ml/variant_layout.ml +++ b/compiler/ml/variant_layout.ml @@ -131,15 +131,13 @@ let check_invariant ~(consts : (Location.t * tag) list) (* Keyed by [literal_key], with the spelling of the literal *) let nonstring_literals_consts = ref String_map.empty in let nonstring_literals_blocks = ref String_map.empty in - let instance_types = Hashtbl.create 1 in - let function_types = ref 0 in - let object_types = ref 0 in - let string_types = ref 0 in - let number_types = ref 0 in - let bigint_types = ref 0 in - let boolean_types = ref 0 in - let symbol_types = ref 0 in - let unknown_types = ref 0 in + (* The kinds of the untagged payloads seen so far. A class is identified by + its name. *) + let kinds = Hashtbl.create 1 in + let kind_key = function + | InstanceType (Class {name}) -> InstanceType (Class {name; ancestors = []}) + | kind -> kind + in let add_string_literal ~is_const ~loc s = let set = if is_const then string_literals_consts else string_literals_blocks @@ -164,32 +162,6 @@ let check_invariant ~(consts : (Location.t * tag) list) | None -> ()); map := String_map.add key s !map in - let invariant loc name = - if !unknown_types <> 0 && List.length blocks <> 1 then - raise - (Error (loc, InvalidUntaggedVariantDefinition (OnlyOneUnknown name))); - if !object_types > 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneObject)); - Hashtbl.iter - (fun _ (i, count) -> - if count > 1 then - raise - (Error (loc, InvalidUntaggedVariantDefinition (AtMostOneInstance i)))) - instance_types; - if !function_types > 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneFunction)); - if !string_types > 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneString)); - if !number_types > 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneNumber)); - if !bigint_types > 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneBigint)); - if !boolean_types > 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneBoolean)); - if !symbol_types > 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneSymbol)); - () - in let check_literal ~is_const ~loc (tag : tag) = match tag.literal with | String s -> add_string_literal ~is_const ~loc s @@ -214,39 +186,34 @@ let check_invariant ~(consts : (Location.t * tag) list) Ext_list.rev_iter blocks (fun (loc, block) -> match block with | Tagged {tag} -> check_literal ~is_const:false ~loc tag + | Untagged {tag; block_type = UnknownType} -> + (* No check tells an unknown payload apart from another payload *) + if List.length blocks <> 1 then + raise + (Error + (loc, InvalidUntaggedVariantDefinition (OnlyOneUnknown tag.name))) | Untagged {tag; block_type} -> - (match block_type with - | UnknownType -> incr unknown_types - | ObjectType -> incr object_types - | InstanceType i -> - (* A class is identified by its name *) - let name = Instance.to_string i in - let count = - match Hashtbl.find_opt instance_types name with - | Some (_, count) -> count - | None -> 0 - in - Hashtbl.replace instance_types name (i, count + 1) - | SymbolType -> incr symbol_types - | FunctionType -> incr function_types - | NumberType -> incr number_types - | BigintType -> incr bigint_types - | BooleanType -> - (* Literal cases are matched before payload cases, so a boolean - payload only receives the booleans that are not literal cases. - A partial overlap is allowed, like for strings and numbers. *) - if - String_map.mem "true" !nonstring_literals_consts - && String_map.mem "false" !nonstring_literals_consts - then - raise - (Error - ( loc, - InvalidUntaggedVariantDefinition - (UnreachableBoolean tag.name) )); - incr boolean_types - | StringType -> incr string_types); - invariant loc tag.name) + (* Literal cases are matched before payload cases, so a boolean + payload only receives the booleans that are not literal cases. A + partial overlap is allowed, like for strings and numbers. *) + if + block_type = BooleanType + && String_map.mem "true" !nonstring_literals_consts + && String_map.mem "false" !nonstring_literals_consts + then + raise + (Error + ( loc, + InvalidUntaggedVariantDefinition (UnreachableBoolean tag.name) + )); + let key = kind_key block_type in + if Hashtbl.mem kinds key then + raise + (Error + ( loc, + InvalidUntaggedVariantDefinition (AtMostOneOfKind block_type) + )); + Hashtbl.add kinds key ()) (* A constructor without [@as] is represented by its name *) From da8baf1d33797f92b205da356b3d2b6d72f21bfb Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sun, 25 Oct 2026 15:00:02 +0000 Subject: [PATCH 12/13] See through private abbreviations and JavaScript object types Why: The structural classifier did not expand private abbreviations, so `private r` of a record was unknown while `private string` was a string, and it called JavaScript object types unknown although their typeof is always "object". Contradictions with an array type printed it as @typeOf("object"). `payload_kind` expands private abbreviations and classifies `{"x": int}` as an object. An annotation contradicting an array type names Array.isArray, and @instanceOf over an array type has an error of its own. Typing rules changed (payload kinds of rule 4): Example: type r = {x: int} type pr = private r @unboxed type t = A(pr) | B({"y": int}) | S(string) Before (rule): `pr` and `{"y": int}` are unknown payloads After (rule): both are object payloads, so only one of them may be a case Diagnostic changed (an annotation over a tuple): Example: @typeOf("object") type t = private (int, int) Before (diagnostic): This annotation, @typeOf("object"), contradicts the abbreviated type, whose values are recognized by @typeOf("object"). After (diagnostic): This annotation, @typeOf("object"), contradicts the abbreviated type, whose values are recognized by Array.isArray. Diagnostic added (a class over an array type): Example: @instanceOf("MyArr") type myArr = private array Before (diagnostic): This annotation, @instanceOf("MyArr"), contradicts the abbreviated type, whose values are recognized by @typeOf("object"). After (diagnostic): @instanceOf("MyArr") cannot describe the values of an array type: they are recognized by Array.isArray, and subclasses of Array are not supported. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- compiler/ml/UntaggedVariants.md | 10 +- compiler/ml/ast_untagged_variants.ml | 7 ++ compiler/ml/typedecl.ml | 13 ++- compiler/ml/variant_layout.ml | 17 +-- .../instance_of_array_subclass.res.expected | 8 ++ ..._annotation_contradicts_tuple.res.expected | 8 ++ .../fixtures/instance_of_array_subclass.res | 1 + .../runtime_annotation_contradicts_tuple.res | 1 + .../src/untagged_runtime_annotations_test.mjs | 100 +++++++++++------- .../src/untagged_runtime_annotations_test.res | 28 +++++ 10 files changed, 140 insertions(+), 53 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/instance_of_array_subclass.res.expected create mode 100644 tests/build_tests/super_errors/expected/runtime_annotation_contradicts_tuple.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/instance_of_array_subclass.res create mode 100644 tests/build_tests/super_errors/fixtures/runtime_annotation_contradicts_tuple.res diff --git a/compiler/ml/UntaggedVariants.md b/compiler/ml/UntaggedVariants.md index ee03b23c03..c40b835f77 100644 --- a/compiler/ml/UntaggedVariants.md +++ b/compiler/ml/UntaggedVariants.md @@ -99,7 +99,7 @@ into one kind: | `bigint` | bigint | `typeof x === "bigint"` | | `bool` | boolean | `typeof x === "boolean"` | | a function type | function | `typeof x === "function"` | -| a record (not `@unboxed`), an inline record, `dict<_>` | object | `typeof x === "object"` | +| a record (not `@unboxed`), an inline record, a JavaScript object type `{"x": int}`, `dict<_>` | object | `typeof x === "object"` | | `array<_>`, a tuple | instance `Array` | `Array.isArray(x)` | | a type declared with `@instanceOf("C")` (rule 5) | instance `C` | `x instanceof C` | | `promise<_>` | instance `Promise` | `x instanceof Promise` | @@ -109,8 +109,9 @@ into one kind: The builtin types state their kinds in their declarations, as the annotations of rule 5 do for declared types. The shape is read from the type as written and from each type it abbreviates, and a tuple, a function type -or a record is classified after expanding abbreviations: `type ints = -array` is an array case, and `type name = string` a string case. Every +or a record is classified after expanding abbreviations, private ones +included: `type ints = array` is an array case, and `type name = +private string` a string case. Every reader of rule 5 uses this one classification. A type is never recognized by its name. `@typeOf("number")` is the number kind, and `@typeOf("symbol")` is a kind of its own, with no @@ -184,10 +185,11 @@ would `type dog = animal` or `type dog = phantom` with | --- | --- | --- | | `@typeOf("string") type t = option`, `type t<'a> = 'a`, an abbreviation of `unit`, `list<_>` or a variant | @typeOf on a type abbreviation must describe an abstract type, ... | `runtime_annotation_on_option.res`, `runtime_annotation_on_type_variable.res` | | `@notUndefined type t = option` | @notUndefined on a type abbreviation must describe an abstract type, ... | `not_undefined_on_option.res`, `tests/build_tests/not_undefined_attribute` | -| `@typeOf("number") type t = sym` with `@typeOf("symbol") type sym`, `@typeOf("string") type t = int`, or an abbreviation of a function type or a record | This annotation, @typeOf("number"), contradicts the abbreviated type, whose values are recognized by @typeOf("symbol"). | `runtime_annotation_contradicts_manifest.res`, `runtime_annotation_contradicts_builtin.res`, `runtime_annotation_contradicts_function.res` | +| `@typeOf("number") type t = sym` with `@typeOf("symbol") type sym`, `@typeOf("string") type t = int`, or an abbreviation of a function type, a record or a tuple | This annotation, @typeOf("number"), contradicts the abbreviated type, whose values are recognized by @typeOf("symbol"). An array or tuple is recognized by Array.isArray. | `runtime_annotation_contradicts_manifest.res`, `runtime_annotation_contradicts_builtin.res`, `runtime_annotation_contradicts_function.res`, `runtime_annotation_contradicts_tuple.res` | | `@instanceOf("Date") type date = X.t` in a functor of `X`, or over `(type a)`; `@notUndefined type t = X.t` | @instanceOf cannot describe the type of a functor parameter, ... | `instance_of_functor_parameter.res`, `type_of_locally_abstract_type.res`, `not_undefined_on_functor_parameter_type.res` | | `@instanceOf("Dog") type dog = animal`, `= animal`, or `= phantom` with `type phantom<'a> = animal` | A subclass must be a private abbreviation ... | `instance_of_public_subclass.res`, `instance_of_public_subclass_instance.res`, `instance_of_public_subclass_through_alias.res` | | `@instanceOf("Animal") type t = private dog` | Animal appears twice in this chain of abbreviations ... | `instance_of_class_twice_in_chain.res` | +| `@instanceOf("MyList") type t = private array` | @instanceOf("MyList") cannot describe the values of an array type: ... subclasses of Array are not supported. | `instance_of_array_subclass.res` | | any of the three on a record or variant | @instanceOf can only be used on abstract types and type abbreviations ... | `runtime_annotation_on_record.res`, `invalid_attribute_not_undefined.res` | | two of the three | A type can have only one of @notUndefined, @instanceOf and @typeOf. ... | `runtime_annotation_conflict.res`, `runtime_annotation_not_undefined_conflict.res` | | one annotation twice | Duplicate @instanceOf annotation; a type can have only one. | `instance_of_duplicate.res` | diff --git a/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml index 2fbb12ade3..12622de7d4 100644 --- a/compiler/ml/ast_untagged_variants.ml +++ b/compiler/ml/ast_untagged_variants.ml @@ -33,6 +33,7 @@ type error = | RuntimeAnnotationOnRepresentedType of string | RuntimeAnnotationOnUnrelatedType of string | RuntimeAnnotationContradictsManifest of string * string + | SubclassOfArray of string | SubclassOfPublicAbbreviation of string * string | ClassTwiceInChain of string exception Error of Location.t * error @@ -162,6 +163,12 @@ let report_error ppf = "This annotation, %s, contradicts the abbreviated type, whose values are \ recognized by %s." outer inner + | SubclassOfArray name -> + fprintf ppf + "@instanceOf(\"%s\") cannot describe the values of an array type: they \ + are recognized by Array.isArray, and subclasses of Array are not \ + supported." + name | SubclassOfPublicAbbreviation (name, ancestor) -> fprintf ppf "A subclass must be a private abbreviation: write `= private ...` so \ diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index 0fa8da5d7d..56d40da590 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -387,16 +387,19 @@ let check_manifest_annotation ~loc ~env (decl : Types.type_declaration) = if decl.type_private = Public then error (SubclassOfPublicAbbreviation (name, superclass)) else if List.mem name ancestors then error (ClassTwiceInChain name) + | Instance_of name, Some (InstanceType Array) -> + error (SubclassOfArray name) | (Instance_of _ | Type_of _), Some inner -> - let inner = + let recognized_by = match inner with - | InstanceType (Class {name}) -> Instance_of name - | block_type -> Type_of block_type + | InstanceType (Class {name}) -> + runtime_annotation_to_string (Instance_of name) + | InstanceType Array -> "Array.isArray" + | block_type -> runtime_annotation_to_string (Type_of block_type) in error (RuntimeAnnotationContradictsManifest - ( runtime_annotation_to_string outer, - runtime_annotation_to_string inner ))) + (runtime_annotation_to_string outer, recognized_by))) let transl_declaration ~type_record_as_object env sdecl id = Ast_untagged_variants.check_runtime_annotation ~loc:sdecl.ptype_loc diff --git a/compiler/ml/variant_layout.ml b/compiler/ml/variant_layout.ml index 12300c4725..1c23edee71 100644 --- a/compiler/ml/variant_layout.ml +++ b/compiler/ml/variant_layout.ml @@ -35,19 +35,22 @@ let recognized_as ~env t = (* The payload kind of the values of [t]: the one its declarations state, or the one its structure gives. Builtin types state their kinds in [Predef]; - type expressions other than constructors have no declaration. An unboxed - record is the value of its field, so it has no kind of its own. *) + type expressions other than constructors have no declaration. A private + abbreviation hides how its values are built, not what they are, so it is + expanded like any other. An unboxed record is the value of its field, so it + has no kind of its own. *) let payload_kind ~env (t : Types.type_expr) : block_type option = match recognized_as ~env t with | Some _ as declared -> declared | None -> ( - match (Ctype.expand_head env t).desc with + match (Ctype.expand_head_opt env t).desc with | Ttuple _ -> Some (InstanceType Array) | Tarrow _ -> Some FunctionType - | Tconstr _ -> ( - match Ctype.extract_concrete_typedecl env t with - | _, _, {type_kind = Type_record (_, Record_unboxed _)} -> None - | _, _, {type_kind = Type_record _} -> Some ObjectType + | Tobject _ -> Some ObjectType + | Tconstr (path, _, _) -> ( + match Env.find_type path env with + | {type_kind = Type_record (_, Record_unboxed _)} -> None + | {type_kind = Type_record _} -> Some ObjectType | _ -> None | exception Not_found -> None) | _ -> None) diff --git a/tests/build_tests/super_errors/expected/instance_of_array_subclass.res.expected b/tests/build_tests/super_errors/expected/instance_of_array_subclass.res.expected new file mode 100644 index 0000000000..9c69069cca --- /dev/null +++ b/tests/build_tests/super_errors/expected/instance_of_array_subclass.res.expected @@ -0,0 +1,8 @@ + + We've found a bug for you! + /.../fixtures/instance_of_array_subclass.res:1:22-52 + + 1 │ @instanceOf("MyArr") type myArr = private array + 2 │ + + @instanceOf("MyArr") cannot describe the values of an array type: they are recognized by Array.isArray, and subclasses of Array are not supported. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/runtime_annotation_contradicts_tuple.res.expected b/tests/build_tests/super_errors/expected/runtime_annotation_contradicts_tuple.res.expected new file mode 100644 index 0000000000..b29722bc9c --- /dev/null +++ b/tests/build_tests/super_errors/expected/runtime_annotation_contradicts_tuple.res.expected @@ -0,0 +1,8 @@ + + We've found a bug for you! + /.../fixtures/runtime_annotation_contradicts_tuple.res:1:19-45 + + 1 │ @typeOf("object") type t = private (int, int) + 2 │ + + This annotation, @typeOf("object"), contradicts the abbreviated type, whose values are recognized by Array.isArray. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/instance_of_array_subclass.res b/tests/build_tests/super_errors/fixtures/instance_of_array_subclass.res new file mode 100644 index 0000000000..0b66500645 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/instance_of_array_subclass.res @@ -0,0 +1 @@ +@instanceOf("MyArr") type myArr = private array diff --git a/tests/build_tests/super_errors/fixtures/runtime_annotation_contradicts_tuple.res b/tests/build_tests/super_errors/fixtures/runtime_annotation_contradicts_tuple.res new file mode 100644 index 0000000000..e4065b1322 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/runtime_annotation_contradicts_tuple.res @@ -0,0 +1 @@ +@typeOf("object") type t = private (int, int) diff --git a/tests/tests/src/untagged_runtime_annotations_test.mjs b/tests/tests/src/untagged_runtime_annotations_test.mjs index bccd06f8a1..0ae9b4d5d8 100644 --- a/tests/tests/src/untagged_runtime_annotations_test.mjs +++ b/tests/tests/src/untagged_runtime_annotations_test.mjs @@ -125,6 +125,22 @@ function restatedAbstractKind(value) { } } +function privateOrNameKind(value) { + if (typeof value === "string") { + return value; + } else { + return value.px.toString(); + } +} + +function jsOrNameKind(value) { + if (typeof value === "string") { + return value; + } else { + return value.pz.toString(); + } +} + function id(x) { return x; } @@ -168,79 +184,87 @@ function sharedKind(value) { Mocha.describe("Untagged_runtime_annotations_test", () => { Mocha.test("a subclass case is not taken for its superclass", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 218, characters 7-14", "animal", describePet(new UntaggedAnimal())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 219, characters 7-14", "dog", describePet(new UntaggedDog())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 220, characters 7-14", "rex", "rex"); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 242, characters 7-14", "animal", describePet(new UntaggedAnimal())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 243, characters 7-14", "dog", describePet(new UntaggedDog())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 244, characters 7-14", "rex", "rex"); }); Mocha.test("a superclass case alone excludes the subclass", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 224, characters 7-14", "animal", onlyAnimal(new UntaggedAnimal())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 225, characters 7-14", "other", onlyAnimal(new UntaggedDog())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 248, characters 7-14", "animal", onlyAnimal(new UntaggedAnimal())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 249, characters 7-14", "other", onlyAnimal(new UntaggedDog())); }); Mocha.test("declaration order does not matter", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 229, characters 7-14", "dog", describeReversed(new UntaggedDog())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 230, characters 7-14", "animal", describeReversed(new UntaggedAnimal())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 253, characters 7-14", "dog", describeReversed(new UntaggedDog())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 254, characters 7-14", "animal", describeReversed(new UntaggedAnimal())); }); Mocha.test("a subclass upcasts to its superclass", () => { let animal = new UntaggedDog(); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 235, characters 7-14", "dog", describePet(animal)); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 259, characters 7-14", "dog", describePet(animal)); }); Mocha.test("classes reached through a module alias", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 239, characters 7-14", "animal", describeAliased(new UntaggedAnimal())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 240, characters 7-14", "dog", describeAliased(new UntaggedDog())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 263, characters 7-14", "animal", describeAliased(new UntaggedAnimal())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 264, characters 7-14", "dog", describeAliased(new UntaggedDog())); }); Mocha.test("typeOf symbol", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 244, characters 7-14", "symbol", keyKind(Symbol.for("key"))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 245, characters 7-14", "text", "text"); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 268, characters 7-14", "symbol", keyKind(Symbol.for("key"))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 269, characters 7-14", "text", "text"); }); Mocha.test("typeOf string", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 249, characters 7-14", "id", "id"); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 250, characters 7-14", "index", "index"); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 273, characters 7-14", "id", "id"); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 274, characters 7-14", "index", "index"); }); Mocha.test("a class at a dotted path", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 254, characters 7-14", "locale", localeKind(new Intl.Locale("en"))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 255, characters 7-14", "de", "de"); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 278, characters 7-14", "locale", localeKind(new Intl.Locale("en"))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 279, characters 7-14", "de", "de"); }); Mocha.test("an annotated type is not wrapped in an option", () => { let animal = new UntaggedAnimal(); - Test_utils.ok("File \"untagged_runtime_annotations_test.res\", line 260, characters 7-14", animal === animal); - Test_utils.ok("File \"untagged_runtime_annotations_test.res\", line 261, characters 7-14", animal === animal); + Test_utils.ok("File \"untagged_runtime_annotations_test.res\", line 284, characters 7-14", animal === animal); + Test_utils.ok("File \"untagged_runtime_annotations_test.res\", line 285, characters 7-14", animal === animal); }); Mocha.test("a phantom type hierarchy", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 265, characters 7-14", "animal", describePhantom(new UntaggedAnimal())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 266, characters 7-14", "dog", describePhantom(new UntaggedDog())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 289, characters 7-14", "animal", describePhantom(new UntaggedAnimal())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 290, characters 7-14", "dog", describePhantom(new UntaggedDog())); }); Mocha.test("a function case excludes class instances", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 270, characters 7-14", "callable", handlerKind(new UntaggedCallable())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 271, characters 7-14", "function", handlerKind(x => x)); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 294, characters 7-14", "callable", handlerKind(new UntaggedCallable())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 295, characters 7-14", "function", handlerKind(x => x)); }); Mocha.test("a class declared over an object type", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 275, characters 7-14", "dog", objectOrNameKind(new UntaggedDog())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 276, characters 7-14", "rex", "rex"); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 299, characters 7-14", "dog", objectOrNameKind(new UntaggedDog())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 300, characters 7-14", "rex", "rex"); }); Mocha.test("annotations restating a structural kind", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 280, characters 7-14", "2", restatedKind(id(x => x + 1 | 0))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 281, characters 7-14", "3", restatedKind(id({ + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 304, characters 7-14", "2", restatedKind(id(x => x + 1 | 0))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 305, characters 7-14", "3", restatedKind(id({ px: 3 }))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 282, characters 7-14", "a", restatedKind(id("a"))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 283, characters 7-14", "callback", restatedAbstractKind(id(callback))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 284, characters 7-14", "point", restatedAbstractKind(id(point))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 306, characters 7-14", "a", restatedKind(id("a"))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 307, characters 7-14", "callback", restatedAbstractKind(id(callback))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 308, characters 7-14", "point", restatedAbstractKind(id(point))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 309, characters 7-14", "4", privateOrNameKind(id({ + px: 4 + }))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 310, characters 7-14", "a", privateOrNameKind(id("a"))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 311, characters 7-14", "5", jsOrNameKind(id({ + pz: 5 + }))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 312, characters 7-14", "b", jsOrNameKind(id("b"))); }); Mocha.test("primitive cases are tested before class checks", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 288, characters 7-14", "a", missingKind(id("a"))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 289, characters 7-14", "count", missingKind(id(1))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 316, characters 7-14", "a", missingKind(id("a"))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 317, characters 7-14", "count", missingKind(id(1))); }); Mocha.test("a primitive without an arm skips class checks", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 293, characters 7-14", "a", missingOrDefault(id("a"))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 294, characters 7-14", "other", missingOrDefault(id(1))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 321, characters 7-14", "a", missingOrDefault(id("a"))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 322, characters 7-14", "other", missingOrDefault(id(1))); }); Mocha.test("a default shared by a primitive and an object case", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 298, characters 7-14", "date!", sharedKind(id(new Date()))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 299, characters 7-14", "other!", sharedKind(id({ + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 326, characters 7-14", "date!", sharedKind(id(new Date()))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 327, characters 7-14", "other!", sharedKind(id({ x: 1 }))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 300, characters 7-14", "text!", sharedKind(id("a"))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 301, characters 7-14", "other!", sharedKind(id(1))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 328, characters 7-14", "text!", sharedKind(id("a"))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 329, characters 7-14", "other!", sharedKind(id(1))); }); }); @@ -262,6 +286,8 @@ export { Restated, restatedKind, restatedAbstractKind, + privateOrNameKind, + jsOrNameKind, id, missingKind, missingOrDefault, diff --git a/tests/tests/src/untagged_runtime_annotations_test.res b/tests/tests/src/untagged_runtime_annotations_test.res index 15f3bd38f5..a5ae0eccd5 100644 --- a/tests/tests/src/untagged_runtime_annotations_test.res +++ b/tests/tests/src/untagged_runtime_annotations_test.res @@ -196,6 +196,30 @@ let restatedAbstractKind = value => | AbstractPoint(_) => "point" } +// A private abbreviation has the kind of the type it abbreviates, and a +// JavaScript object type is an object +type privatePoint = private point +external makePrivatePoint: point => privatePoint = "%identity" +type jsPoint = {"pz": int} + +@unboxed +type privateOrName = PrivatePoint(privatePoint) | PrivateName(string) + +let privateOrNameKind = value => + switch value { + | PrivatePoint(point) => Int.toString((point :> point).px) + | PrivateName(name) => name + } + +@unboxed +type jsOrName = JsPoint(jsPoint) | JsName(string) + +let jsOrNameKind = value => + switch value { + | JsPoint(point) => Int.toString(point["pz"]) + | JsName(name) => name + } + @inline(never) let id = x => x // No class of this name exists at run time @@ -304,6 +328,10 @@ describe(__MODULE__, () => { eq(__LOC__, "a", restatedKind(id(Label("a")))) eq(__LOC__, "callback", restatedAbstractKind(id(AbstractCallback(Restated.callback)))) eq(__LOC__, "point", restatedAbstractKind(id(AbstractPoint(Restated.point)))) + eq(__LOC__, "4", privateOrNameKind(id(PrivatePoint(makePrivatePoint({px: 4}))))) + eq(__LOC__, "a", privateOrNameKind(id(PrivateName("a")))) + eq(__LOC__, "5", jsOrNameKind(id(JsPoint({"pz": 5})))) + eq(__LOC__, "b", jsOrNameKind(id(JsName("b")))) }) test("primitive cases are tested before class checks", () => { From 828bbc414604121156b74143c1b039ccc1b823e2 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sun, 25 Oct 2026 16:29:02 +0000 Subject: [PATCH 13/13] Regenerate the callable-instance test for the typeof dispatch Why: The test added to the bottom of the stack is compiled by this pull request's dispatch, which checks the function arm against the classes. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- .../src/untagged_runtime_annotations_test.mjs | 98 +++++++++++-------- 1 file changed, 57 insertions(+), 41 deletions(-) diff --git a/tests/tests/src/untagged_runtime_annotations_test.mjs b/tests/tests/src/untagged_runtime_annotations_test.mjs index 0ae9b4d5d8..99d58fcefd 100644 --- a/tests/tests/src/untagged_runtime_annotations_test.mjs +++ b/tests/tests/src/untagged_runtime_annotations_test.mjs @@ -86,6 +86,16 @@ function handlerKind(handler) { } } +function wideHandlerKind(handler) { + if (typeof handler === "string") { + return "name"; + } else if (typeof handler === "function" && !(handler instanceof UntaggedAnimal) && !(handler instanceof UntaggedCallable)) { + return "function"; + } else { + return "other"; + } +} + function objectOrNameKind(value) { if (typeof value === "string") { return value; @@ -184,87 +194,92 @@ function sharedKind(value) { Mocha.describe("Untagged_runtime_annotations_test", () => { Mocha.test("a subclass case is not taken for its superclass", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 242, characters 7-14", "animal", describePet(new UntaggedAnimal())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 243, characters 7-14", "dog", describePet(new UntaggedDog())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 244, characters 7-14", "rex", "rex"); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 259, characters 7-14", "animal", describePet(new UntaggedAnimal())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 260, characters 7-14", "dog", describePet(new UntaggedDog())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 261, characters 7-14", "rex", "rex"); }); Mocha.test("a superclass case alone excludes the subclass", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 248, characters 7-14", "animal", onlyAnimal(new UntaggedAnimal())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 249, characters 7-14", "other", onlyAnimal(new UntaggedDog())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 265, characters 7-14", "animal", onlyAnimal(new UntaggedAnimal())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 266, characters 7-14", "other", onlyAnimal(new UntaggedDog())); }); Mocha.test("declaration order does not matter", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 253, characters 7-14", "dog", describeReversed(new UntaggedDog())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 254, characters 7-14", "animal", describeReversed(new UntaggedAnimal())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 270, characters 7-14", "dog", describeReversed(new UntaggedDog())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 271, characters 7-14", "animal", describeReversed(new UntaggedAnimal())); }); Mocha.test("a subclass upcasts to its superclass", () => { let animal = new UntaggedDog(); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 259, characters 7-14", "dog", describePet(animal)); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 276, characters 7-14", "dog", describePet(animal)); }); Mocha.test("classes reached through a module alias", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 263, characters 7-14", "animal", describeAliased(new UntaggedAnimal())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 264, characters 7-14", "dog", describeAliased(new UntaggedDog())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 280, characters 7-14", "animal", describeAliased(new UntaggedAnimal())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 281, characters 7-14", "dog", describeAliased(new UntaggedDog())); }); Mocha.test("typeOf symbol", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 268, characters 7-14", "symbol", keyKind(Symbol.for("key"))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 269, characters 7-14", "text", "text"); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 285, characters 7-14", "symbol", keyKind(Symbol.for("key"))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 286, characters 7-14", "text", "text"); }); Mocha.test("typeOf string", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 273, characters 7-14", "id", "id"); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 274, characters 7-14", "index", "index"); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 290, characters 7-14", "id", "id"); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 291, characters 7-14", "index", "index"); }); Mocha.test("a class at a dotted path", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 278, characters 7-14", "locale", localeKind(new Intl.Locale("en"))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 279, characters 7-14", "de", "de"); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 295, characters 7-14", "locale", localeKind(new Intl.Locale("en"))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 296, characters 7-14", "de", "de"); }); Mocha.test("an annotated type is not wrapped in an option", () => { let animal = new UntaggedAnimal(); - Test_utils.ok("File \"untagged_runtime_annotations_test.res\", line 284, characters 7-14", animal === animal); - Test_utils.ok("File \"untagged_runtime_annotations_test.res\", line 285, characters 7-14", animal === animal); + Test_utils.ok("File \"untagged_runtime_annotations_test.res\", line 301, characters 7-14", animal === animal); + Test_utils.ok("File \"untagged_runtime_annotations_test.res\", line 302, characters 7-14", animal === animal); }); Mocha.test("a phantom type hierarchy", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 289, characters 7-14", "animal", describePhantom(new UntaggedAnimal())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 290, characters 7-14", "dog", describePhantom(new UntaggedDog())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 306, characters 7-14", "animal", describePhantom(new UntaggedAnimal())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 307, characters 7-14", "dog", describePhantom(new UntaggedDog())); }); Mocha.test("a function case excludes class instances", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 294, characters 7-14", "callable", handlerKind(new UntaggedCallable())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 295, characters 7-14", "function", handlerKind(x => x)); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 311, characters 7-14", "callable", handlerKind(new UntaggedCallable())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 312, characters 7-14", "function", handlerKind(x => x)); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 313, characters 7-14", "other", wideHandlerKind(new UntaggedCallable())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 314, characters 7-14", "other", wideHandlerKind(new UntaggedAnimal())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 315, characters 7-14", "function", wideHandlerKind(x => x)); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 316, characters 7-14", "name", "name"); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 317, characters 7-14", "other", "other"); }); Mocha.test("a class declared over an object type", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 299, characters 7-14", "dog", objectOrNameKind(new UntaggedDog())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 300, characters 7-14", "rex", "rex"); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 321, characters 7-14", "dog", objectOrNameKind(new UntaggedDog())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 322, characters 7-14", "rex", "rex"); }); Mocha.test("annotations restating a structural kind", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 304, characters 7-14", "2", restatedKind(id(x => x + 1 | 0))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 305, characters 7-14", "3", restatedKind(id({ + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 326, characters 7-14", "2", restatedKind(id(x => x + 1 | 0))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 327, characters 7-14", "3", restatedKind(id({ px: 3 }))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 306, characters 7-14", "a", restatedKind(id("a"))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 307, characters 7-14", "callback", restatedAbstractKind(id(callback))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 308, characters 7-14", "point", restatedAbstractKind(id(point))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 309, characters 7-14", "4", privateOrNameKind(id({ + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 328, characters 7-14", "a", restatedKind(id("a"))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 329, characters 7-14", "callback", restatedAbstractKind(id(callback))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 330, characters 7-14", "point", restatedAbstractKind(id(point))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 331, characters 7-14", "4", privateOrNameKind(id({ px: 4 }))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 310, characters 7-14", "a", privateOrNameKind(id("a"))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 311, characters 7-14", "5", jsOrNameKind(id({ + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 332, characters 7-14", "a", privateOrNameKind(id("a"))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 333, characters 7-14", "5", jsOrNameKind(id({ pz: 5 }))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 312, characters 7-14", "b", jsOrNameKind(id("b"))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 334, characters 7-14", "b", jsOrNameKind(id("b"))); }); Mocha.test("primitive cases are tested before class checks", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 316, characters 7-14", "a", missingKind(id("a"))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 317, characters 7-14", "count", missingKind(id(1))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 338, characters 7-14", "a", missingKind(id("a"))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 339, characters 7-14", "count", missingKind(id(1))); }); Mocha.test("a primitive without an arm skips class checks", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 321, characters 7-14", "a", missingOrDefault(id("a"))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 322, characters 7-14", "other", missingOrDefault(id(1))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 343, characters 7-14", "a", missingOrDefault(id("a"))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 344, characters 7-14", "other", missingOrDefault(id(1))); }); Mocha.test("a default shared by a primitive and an object case", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 326, characters 7-14", "date!", sharedKind(id(new Date()))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 327, characters 7-14", "other!", sharedKind(id({ + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 348, characters 7-14", "date!", sharedKind(id(new Date()))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 349, characters 7-14", "other!", sharedKind(id({ x: 1 }))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 328, characters 7-14", "text!", sharedKind(id("a"))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 329, characters 7-14", "other!", sharedKind(id(1))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 350, characters 7-14", "text!", sharedKind(id("a"))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 351, characters 7-14", "other!", sharedKind(id(1))); }); }); @@ -282,6 +297,7 @@ export { localeKind, describePhantom, handlerKind, + wideHandlerKind, objectOrNameKind, Restated, restatedKind,