diff --git a/changes/untagged-declarations.polish.md b/changes/untagged-declarations.polish.md new file mode 100644 index 00000000000..e95fa333b63 --- /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/core/js_dump.ml b/compiler/core/js_dump.ml index 80b09fb7725..fcacce78a3b 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 678f318e35b..d7685a8f966 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 d29e4c095d0..ca1f407931f 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 08a8293a62b..de9efa656d2 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 070e42f22e0..c40b835f771 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 @@ -99,22 +99,26 @@ 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` | | 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 = -string` a string case. A type is never recognized by its name. `@typeOf("number")` +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, 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 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:payload_kind`, `get_block_type`, `recognized_as`. - Tests: `spec_test` rules 4 (`kinds`, `tuples`, `aliasDict`, `instances`, `unknown`); fixtures `UntaggedConstructorMoreThanOneArg.res`, `UntaggedConstructorAttributeMoreThanOneArg.res`, `UntaggedNonUnary1.res`, @@ -125,20 +129,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 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). 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 @@ -149,13 +161,17 @@ 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 -the annotation of the abbreviated type. 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 (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 cannot be refined. Only a private abbreviation can declare a subclass of the @@ -167,15 +183,38 @@ 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` | -| `@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` | +| `@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, 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` 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` | +| `@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` | +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 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`), 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 +`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: @@ -212,17 +251,27 @@ 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`; + `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`. - 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 @@ -259,7 +308,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`, @@ -422,7 +471,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 | @@ -455,39 +504,7 @@ hold `undefined`. `tests/build_tests/option_transitive_dependency`. - Shaped by #6222, #6233, #8719, #8954. -### 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. - -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`; - `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/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 @@ -497,33 +514,21 @@ 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. 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 -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 @@ -552,15 +557,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/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml index c95d2050960..12622de7d4d 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 @@ -40,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 @@ -66,22 +60,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 @@ -148,7 +144,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 \ @@ -162,8 +160,15 @@ 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 + | 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 \ @@ -241,12 +246,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" @@ -293,6 +300,7 @@ let is_class_path name = | [] -> false let runtime_attribute_name = function + | Not_undefined -> not_undefined | Instance_of _ -> instance_of | Type_of _ -> type_of @@ -301,6 +309,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) @@ -316,16 +325,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 @@ -382,7 +390,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} @@ -391,140 +399,12 @@ 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 - | None -> add_string_literal ~is_const ~loc tag.name - | Some (String s) -> add_string_literal ~is_const ~loc s - | Some (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) -> - add_nonstring_literal ~is_const ~loc literal (i ^ "n") - | Some (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) -> - 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) +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 51d926eaae2..b1326f398a7 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 _ -> @@ -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 2b3087037f8..09bea4bbb9c 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/error_message_utils.ml b/compiler/ml/error_message_utils.ml index 8665b0c6fb8..67031fa22e9 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/includecore.ml b/compiler/ml/includecore.ml index 62d1546b67e..5b86154e005 100644 --- a/compiler/ml/includecore.ml +++ b/compiler/ml/includecore.ml @@ -345,21 +345,32 @@ 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 + (* 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 @@ -395,7 +406,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 08f44bbe4ae..890c6c97ded 100644 --- a/compiler/ml/includemod.ml +++ b/compiler/ml/includemod.ml @@ -62,42 +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. 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. *) -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 - 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] - 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))]) diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 9912aade63f..71cc84490b2 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. *) @@ -915,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 @@ -932,9 +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 = Some (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 @@ -948,13 +943,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) @@ -1015,13 +1018,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 +1176,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 d768ff18dba..bd469b6c93f 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/predef.ml b/compiler/ml/predef.ml index 8ed35b7056d..f7e134ca3a9 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/printtyp.ml b/compiler/ml/printtyp.ml index 85e05d46775..3963d5cf9a8 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/typedecl.ml b/compiler/ml/typedecl.ml index d6f78c0c746..56d40da5907 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,72 @@ let make_constructor env type_path type_params sargs sret_type = any type variable present in [ty]. *) +(* 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 name, Some (InstanceType Array) -> + error (SubclassOfArray name) + | (Instance_of _ | Type_of _), Some inner -> + let recognized_by = + match inner with + | 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, recognized_by))) + let transl_declaration ~type_record_as_object env sdecl id = - (* Check for @notUndefined attribute *) - let has_not_undefined = - 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" ))); Ast_untagged_variants.check_runtime_annotation ~loc:sdecl.ptype_loc ~is_abstract_or_abbreviation:(sdecl.ptype_kind = Ptype_abstract) sdecl.ptype_attributes; @@ -1343,7 +1362,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 +1642,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_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 *) @@ -2037,7 +2055,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_annotation ~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 +2189,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 f12a53a9670..8a534544f31 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 fce5edc493d..35ef4d6661e 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 @@ -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 @@ -122,6 +122,46 @@ 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 + | Stands_for_another + | Can_be_undefined + +(* Whether a type can hold [undefined], as far as the compiler sees. An + 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 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 | Tarrow (params, ret) -> Some ((List.hd params).typ, ret) diff --git a/compiler/ml/typeopt.mli b/compiler/ml/typeopt.mli index f51b0227f08..c46aa5da12c 100644 --- a/compiler/ml/typeopt.mli +++ b/compiler/ml/typeopt.mli @@ -22,3 +22,21 @@ 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 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 *) +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_coercion.ml b/compiler/ml/variant_coercion.ml index cac2b9b44d3..11e90a6e71a 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 88f87e3991c..1c23edee719 100644 --- a/compiler/ml/variant_layout.ml +++ b/compiler/ml/variant_layout.ml @@ -33,11 +33,34 @@ 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. 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_opt env t).desc with + | Ttuple _ -> Some (InstanceType Array) + | Tarrow _ -> Some FunctionType + | 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) + (* 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. *) 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 = @@ -49,8 +72,11 @@ 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 + | 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 @@ -85,115 +111,9 @@ 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, recognized_as ~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_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 *) - 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) - 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) @@ -202,10 +122,108 @@ 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 + (* 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 + 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 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 = 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} -> + (* 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 *) + 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 4b21e9294da..2c04022f550 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 81a6153c940..1d57cd6fa0e 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/build_tests/not_undefined_attribute/demo.res b/tests/build_tests/not_undefined_attribute/demo.res index cdd9eb9de18..50134526127 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 b37a4d14e27..9b3200c91aa 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/instance_of_array_subclass.res.expected b/tests/build_tests/super_errors/expected/instance_of_array_subclass.res.expected new file mode 100644 index 00000000000..9c69069ccae --- /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/invalid_attribute_not_undefined.res.expected b/tests/build_tests/super_errors/expected/invalid_attribute_not_undefined.res.expected index fe75ea5d4e1..30f9a87b735 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 00000000000..d9f374df594 --- /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 00000000000..720a9d04626 --- /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/expected/runtime_annotation_conflict.res.expected b/tests/build_tests/super_errors/expected/runtime_annotation_conflict.res.expected index 1283d8bc21f..d6758b65a50 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_contradicts_builtin.res.expected b/tests/build_tests/super_errors/expected/runtime_annotation_contradicts_builtin.res.expected new file mode 100644 index 00000000000..3473490b2ec --- /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_function.res.expected b/tests/build_tests/super_errors/expected/runtime_annotation_contradicts_function.res.expected new file mode 100644 index 00000000000..edd0d1c6ddc --- /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_contradicts_manifest.res.expected b/tests/build_tests/super_errors/expected/runtime_annotation_contradicts_manifest.res.expected index fcc9121b913..b0de7da319e 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/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 00000000000..b29722bc9c9 --- /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/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 00000000000..2bf2b452013 --- /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/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 00000000000..35123850bd1 --- /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/instance_of_array_subclass.res b/tests/build_tests/super_errors/fixtures/instance_of_array_subclass.res new file mode 100644 index 00000000000..0b665006459 --- /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/invalid_attribute_not_undefined.res b/tests/build_tests/super_errors/fixtures/invalid_attribute_not_undefined.res index cdd9eb9de18..b57e947694a 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 00000000000..ee01b578a12 --- /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 00000000000..9f6d5044531 --- /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/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 00000000000..b3e518808cf --- /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/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 00000000000..86a148bd4e5 --- /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_contradicts_tuple.res b/tests/build_tests/super_errors/fixtures/runtime_annotation_contradicts_tuple.res new file mode 100644 index 00000000000..e4065b1322b --- /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/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 00000000000..5d079ed1643 --- /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/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 00000000000..2eac10d8a24 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/runtime_annotation_not_undefined_conflict.res @@ -0,0 +1 @@ +@notUndefined @typeOf("string") type t diff --git a/tests/ounit_tests/ounit_lambda_constant_tests.ml b/tests/ounit_tests/ounit_lambda_constant_tests.ml index 5fa2219cc5d..8b674b5cba4 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 00000000000..74c585a1129 --- /dev/null +++ b/tests/tests/src/as_constructor_name_test.mjs @@ -0,0 +1,41 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + +import * as Mocha from "mocha"; +import * as Test_utils from "./test_utils.mjs"; + +let Stated = { + a: "A" +}; + +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 50, characters 7-14", "A", "A")); + Mocha.test("folded matches of coerced constants", () => { + 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 60, characters 7-14", "A", "A")); +}); + +let declaredA = "A"; + +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 new file mode 100644 index 00000000000..ff506e13143 --- /dev/null +++ b/tests/tests/src/as_constructor_name_test.res @@ -0,0 +1,62 @@ +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 +} + +// 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 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) + +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) + eq(__LOC__, isOneInt((OneInt: sourceInt) :> targetFloat), true) + }) + + test("interface", () => { + eq(__LOC__, Stated.a, Stated.A) + }) +}) 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 00000000000..56fb3dbe1ce --- /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 00000000000..d9f978f1535 --- /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") + }) +}) diff --git a/tests/tests/src/untagged_builtin_alias_test.mjs b/tests/tests/src/untagged_builtin_alias_test.mjs index 8346c5a56a1..686d8700f09 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 d5de5e80ee2..3548fac2963 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"))) + }) }) diff --git a/tests/tests/src/untagged_runtime_annotations_test.mjs b/tests/tests/src/untagged_runtime_annotations_test.mjs index 9e80734b949..99d58fcefd3 100644 --- a/tests/tests/src/untagged_runtime_annotations_test.mjs +++ b/tests/tests/src/untagged_runtime_annotations_test.mjs @@ -104,6 +104,53 @@ 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 value.px.toString(); + } +} + +function restatedAbstractKind(value) { + if (typeof value === "function") { + return "callback"; + } else { + return "point"; + } +} + +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; } @@ -147,75 +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 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 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 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 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 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 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 216, 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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))); }); }); @@ -235,6 +299,11 @@ export { handlerKind, wideHandlerKind, objectOrNameKind, + 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 062bf85fcab..a5ae0eccd53 100644 --- a/tests/tests/src/untagged_runtime_annotations_test.res +++ b/tests/tests/src/untagged_runtime_annotations_test.res @@ -160,6 +160,66 @@ 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" + } + +// 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 @@ -262,6 +322,18 @@ 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)))) + 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", () => { eq(__LOC__, "a", missingKind(id(Text("a")))) eq(__LOC__, "count", missingKind(id(Count(1.)))) diff --git a/tests/tests/src/untagged_variants_spec_test.mjs b/tests/tests/src/untagged_variants_spec_test.mjs index 0612499b8e1..1e6cf243367 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 fc65258e765..1773fe855d6 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")