From e99e3ae102afc21c7577150b36547752f88c199b Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 24 Oct 2026 10:17:59 +0000 Subject: [PATCH 01/19] Match untagged variants with a literal switch and one typeof dispatch Why: The payload dispatch of an untagged variant ran its instance checks before the `typeof` checks, so strings and numbers reached `instanceof`: a class missing at run time threw for them, and a `Symbol.hasInstance` could claim them. Literals were tested by a size heuristic that chose between two equivalent expressions, the object case by a guard per instance case, and a subclass by negating it in its superclass's check. The literals come first, compared with `===` by one `switch (x)` (an `if` per body for at most two), whose default is the payload dispatch: one `switch (typeof x)` over the primitive kinds, whose default is an `if` chain over the instance cases (a subclass first), the function case, the tagged constructors and the object case. In a complete match the last arm is not checked. A literal without an arm skips the `switch` when no payload check would accept it, and a `null` that only the object check would accept adds `x !== null` to it. Checks leading to the default before the last checked arm fold into its check, so class checks run only on objects. `Dynamic_checks.is_a_literal_case` and the per-instance guards are gone. JS modified (primitives before classes): Example: @unboxed type t = Missing(missing) | Text(string) | Count(float) let kind = value => switch value { | Missing(_) => "missing" | Text(text) => text | Count(_) => "count" } Before (js): if (value instanceof UntaggedMissingClass) { return "missing"; } switch (typeof value) { case "string" : return value; case "number" : return "count"; } After (js): switch (typeof value) { case "string" : return value; case "number" : return "count"; default: return "missing"; } JS modified (instances without an arm): Example: @unboxed type t = D(Date.t) | R(RegExp.t) | O({x: int}) | S(string) | I(int) | F(int => int) let kind = value => switch value { | O(_) => "O" | S(_) => "S" | _ => "other" } Before (js): if (value instanceof RegExp || value instanceof Date) { return "other"; } switch (typeof value) { case "object" : return "O"; case "string" : return "S"; default: return "other"; } After (js): if (typeof value === "string") { return "S"; } else if (typeof value === "object" && !(value instanceof RegExp) && !(value instanceof Date)) { return "O"; } else { return "other"; } JS modified (a subclass first): Example: @unboxed type upload = Blob(Blob.t) | File(File.t) let kind = upload => switch upload { | Blob(_) => "blob" | File(_) => "file" } Before (js): if (upload instanceof Blob && !(upload instanceof File)) { return "blob"; } else { return "file"; } After (js): if (upload instanceof File) { return "file"; } else { return "blob"; } Review: Does `break` in an arm leave the generated `switch` instead of the loop? No: every arm placed in a generated `switch` is compiled in a switch context, where `break` and `continue` are labeled; `untagged_loop_control_test.res` checks arms of every part. Review: What changes for a value outside every case? It lands in the last arm of the chain: with `PPromise | PFloat` the float case is now checked, so a thenable lands in `PPromise` (rule 10). Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- changes/untagged-dispatch.polish.md | 1 + compiler/core/js_exp_make.ml | 7 - compiler/core/js_exp_make.mli | 6 - compiler/core/js_stmt_make.mli | 3 + compiler/core/lam_compile.ml | 556 +++++++++++++----- compiler/ml/UntaggedVariants.md | 141 +++-- compiler/ml/ast_untagged_variants.ml | 148 ----- compiler/ml/variant_runtime.ml | 7 +- tests/tests/src/UntaggedVariants.mjs | 336 +++++------ tests/tests/src/pm_opt_fields_mixed_test.mjs | 18 +- tests/tests/src/unboxed_variant_fold_test.mjs | 30 +- .../tests/src/untagged_builtin_alias_test.mjs | 12 +- tests/tests/src/untagged_default_arm_test.mjs | 108 +++- tests/tests/src/untagged_default_arm_test.res | 66 +++ tests/tests/src/untagged_file_blob_test.mjs | 12 +- .../tests/src/untagged_loop_control_test.mjs | 186 ++++++ .../tests/src/untagged_loop_control_test.res | 94 +++ ...tagged_runtime_annotations_shadow_test.mjs | 11 +- .../src/untagged_runtime_annotations_test.mjs | 163 +++-- .../src/untagged_runtime_annotations_test.res | 51 ++ .../tests/src/untagged_variants_spec_test.mjs | 75 +-- .../tests/src/untagged_variants_spec_test.res | 2 +- tests/tests/src/variantsMatching.mjs | 53 +- 23 files changed, 1326 insertions(+), 760 deletions(-) create mode 100644 changes/untagged-dispatch.polish.md create mode 100644 tests/tests/src/untagged_loop_control_test.mjs create mode 100644 tests/tests/src/untagged_loop_control_test.res diff --git a/changes/untagged-dispatch.polish.md b/changes/untagged-dispatch.polish.md new file mode 100644 index 00000000000..71fd94313c5 --- /dev/null +++ b/changes/untagged-dispatch.polish.md @@ -0,0 +1 @@ +- Match an untagged variant with one `switch` over its literals and one `switch (typeof x)` over its primitive cases before any class check, so that strings and numbers skip `instanceof` and a class missing at run time no longer throws for them. diff --git a/compiler/core/js_exp_make.ml b/compiler/core/js_exp_make.ml index 5b29dc33066..c7d10c264cf 100644 --- a/compiler/core/js_exp_make.ml +++ b/compiler/core/js_exp_make.ml @@ -1428,13 +1428,6 @@ let rec emit_check (check : t Ast_untagged_variants.Dynamic_checks.t) = | Not x -> not (emit_check x) | Expr x -> x -let is_a_literal_case ~literal_cases ~block_cases (e : t) = - let check = - Ast_untagged_variants.Dynamic_checks.is_a_literal_case ~literal_cases - ~block_cases (Expr e) - in - emit_check check - let is_int_tag ?has_null_undefined_other e = let check = Ast_untagged_variants.Dynamic_checks.is_int_tag ?has_null_undefined_other diff --git a/compiler/core/js_exp_make.mli b/compiler/core/js_exp_make.mli index 70f6e7326f8..a699f2e2605 100644 --- a/compiler/core/js_exp_make.mli +++ b/compiler/core/js_exp_make.mli @@ -181,12 +181,6 @@ val neq_null_undefined_boolean : ?comment:string -> t -> t -> t val is_int_tag : ?has_null_undefined_other:bool * bool * bool -> t -> t -val is_a_literal_case : - literal_cases:Variant_runtime.literal_tag list -> - block_cases:Variant_runtime.block_type list -> - t -> - t - val is_type_object : t -> t val typeof : ?comment:string -> t -> t diff --git a/compiler/core/js_stmt_make.mli b/compiler/core/js_stmt_make.mli index b3dbcd9b008..7be481bee98 100644 --- a/compiler/core/js_stmt_make.mli +++ b/compiler/core/js_stmt_make.mli @@ -76,6 +76,9 @@ val string_switch : (Variant_runtime.tag_type * J.case_clause) list -> t +val block_last_is_return_throw_or_continue : J.block -> bool +(** Whether control never falls out of the end of the block *) + val declare_variable : ?comment:string -> ?ident_info:J.ident_info -> diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index 33b44ad5943..1356897d238 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -164,7 +164,13 @@ let group_apply ~merge_cases cases callback = only jmp_table and env needed *) -type default_case = Default of Lambda.t | Complete | NonComplete +type default_case = + | Default of Lambda.t + | Compiled of (Lam_compile_context.t -> J.block) + (** a default compiled by the caller, such as the payload dispatch of + an untagged variant after its literals *) + | Complete + | NonComplete let default_action ~saturated failaction = match failaction with @@ -564,6 +570,7 @@ let compile output_prefix = switch_exp:J.expression -> default:default_case -> ?merge_cases:('a -> 'a -> bool) -> + ?always_switch:bool -> ('a * Lambda.t) list -> J.block = fun (type a) ~(make_exp : a -> J.expression) @@ -576,13 +583,19 @@ let compile output_prefix = _ -> (a * J.case_clause) list -> J.statement) ~(switch_exp : J.expression) ~(default : default_case) - ?(merge_cases = fun _ _ -> true) (cases : (a * Lambda.t) list) -> + ?(merge_cases = fun _ _ -> true) ?(always_switch = false) + (cases : (a * Lambda.t) list) -> let output_block_with_source_loc cxt lam = compile_lambda cxt lam |> Js_output.output_as_block |> with_block_source_loc lam in + let output_default cxt = function + | Default lam -> output_block_with_source_loc cxt lam + | Compiled compile -> compile cxt + | Complete | NonComplete -> [] + in match (cases, default) with - | [], Default lam -> output_block_with_source_loc cxt lam + | [], (Default _ | Compiled _) -> output_default cxt default | [], (Complete | NonComplete) -> [] | [(_, lam)], Complete -> (* To take advantage of such optimizations, @@ -592,14 +605,23 @@ let compile output_prefix = it's also complete *) output_block_with_source_loc cxt lam - | [(id, lam)], NonComplete -> + | [(id, lam)], NonComplete when not always_switch -> morph_declare_to_assign cxt (fun cxt define -> [ S.if_ ?declaration:define (eq_exp None switch_exp (Some id) (make_exp id)) (output_block_with_source_loc cxt lam); ]) - | [(id, lam)], Default x | [(id, lam); (_, x)], Complete -> + | [(id, lam)], (Default _ | Compiled _) when not always_switch -> + morph_declare_to_assign cxt (fun cxt define -> + let else_block = output_default cxt default in + let then_block = output_block_with_source_loc cxt lam in + [ + S.if_ ?declaration:define + (eq_exp None switch_exp (Some id) (make_exp id)) + then_block ~else_:else_block; + ]) + | [(id, lam); (_, x)], Complete when not always_switch -> morph_declare_to_assign cxt (fun cxt define -> let else_block = output_block_with_source_loc cxt x in let then_block = output_block_with_source_loc cxt lam in @@ -639,14 +661,9 @@ let compile output_prefix = in let switch_cxt = Lam_compile_context.enter_switch cxt in let default = - match default with - | Complete -> None - | NonComplete -> None - | Default lam -> ( - let statements = output_block_with_source_loc switch_cxt lam in - match statements with - | [] -> None - | _ -> Some statements) + match output_default switch_cxt default with + | [] -> None + | statements -> Some statements in let body = group_apply ~merge_cases cases (fun last (switch_case, lam) -> @@ -696,14 +713,14 @@ let compile output_prefix = Some ((Literal (String name), lam) :: string_table) | _, _ -> None) table (Some []) - and compile_cases ?(untagged = false) ?(has_null_case = false) ~cxt - ~(switch_exp : E.t) ?(default = NonComplete) ?(block_cases = []) cases : - initialization = + and compile_cases ?(untagged = false) ?(tag_name = Js_dump_lit.tag) + ?(null_guard = false) ~cxt ~(switch_exp : E.t) ?(default = NonComplete) + ?(block_cases = []) cases : initialization = match use_compile_literal_cases cases with | Some string_cases -> if untagged then - compile_untagged_cases ~cxt ~switch_exp ~block_cases ~default - ~has_null_case string_cases + compile_untagged_cases ~cxt ~switch_exp ~block_cases ~tag_name + ~null_guard ~default string_cases else compile_string_cases ~cxt ~switch_exp ~default string_cases | None -> cases @@ -761,7 +778,7 @@ let compile output_prefix = block @ if sw_consts_full && sw_consts = [] then - compile_cases ~block_cases ~untagged ~cxt + compile_cases ~block_cases ~untagged ~tag_name ~cxt ~switch_exp:(if untagged then e else E.tag ~name:tag_name e) ~default:sw_blocks_default sw_blocks else if sw_blocks_full && sw_blocks = [] then @@ -770,59 +787,163 @@ let compile output_prefix = else (* [e] will be used twice *) let dispatch e = - let is_a_literal_case () = - if untagged then E.is_a_literal_case ~literal_cases ~block_cases e - else E.is_int_tag ~has_null_undefined_other e - in - let eq_default d1 d2 = - match (d1, d2) with - | Default lam1, Default lam2 -> Lambda.eq_approx lam1 lam2 - | Complete, Complete -> true - | NonComplete, NonComplete -> true - | _ -> false - in - (* A literal handled by the default would otherwise pass the - check of a payload arm of its kind *) - let a_literal_reaches_an_arm () = - let arm_types = + if untagged then + (* The literals first, compared with [===] by one switch whose + default is the payload dispatch. A literal without an arm + goes to the match's default, never to a payload arm *) + 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) + in + (* A literal reaches the same default through the payload + dispatch when no payload arm accepts its kind and no class + check runs on it *) + 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 _ | None -> None) + | Some {tag_type = Some (Literal _) | None} | None -> + (* A tagged block, an object *) + Some Variant_runtime.ObjectType) in - Ext_list.exists literal_cases - (fun (literal : Variant_runtime.literal_tag) -> - Ext_list.exists arm_types - (fun (block_type : Variant_runtime.block_type) -> - match (literal, block_type) with - | String _, StringType - | (Int _ | Float _), NumberType - | BigInt _, BigintType - | Bool _, BooleanType - | _, UnknownType -> - true - | _, _ -> false)) - in - if - untagged - && List.length sw_consts = 0 - && eq_default sw_num_default sw_blocks_default - && not (a_literal_reaches_an_arm ()) - then - let has_null_case = List.mem Variant_runtime.Null literal_cases in - compile_cases ~untagged ~cxt - ~switch_exp:(if untagged then e else E.tag ~name:tag_name e) - ~block_cases ~has_null_case ~default:sw_blocks_default sw_blocks + let reaches_a_payload_arm (literal : Variant_runtime.literal_tag) + = + List.exists + (fun (block_type : Variant_runtime.block_type) -> + match (block_type, literal) with + | UnknownType, _ + | StringType, String _ + | NumberType, (Int _ | Float _) + | BigintType, BigInt _ + | BooleanType, Bool _ + | ObjectType, Null -> + true + | ( ( StringType | NumberType | BigintType | BooleanType + | ObjectType | InstanceType _ | SymbolType + | FunctionType ), + _ ) -> + false) + payload_arms + in + let has_class_case = + List.exists + (function + | Variant_runtime.InstanceType (Class _) -> true + | _ -> false) + block_cases + in + let unnamed = + List.filter + (fun literal -> not (List.mem literal named)) + literal_cases + in + (* [null] passes only the object check, which then tests + [x !== null] *) + let skips_the_switch (literal : Variant_runtime.literal_tag) = + (not has_class_case) + && ((not (reaches_a_payload_arm literal)) + || literal = Null + && not (List.mem Variant_runtime.UnknownType payload_arms) + ) + in + (* Values no payload arm takes are the literals without an arm: + a complete payload dispatch checks its last arm, and these + literals skip the switch *) + let blocks_default = + match (sw_num_default, sw_blocks_default) with + | Default lam, Complete + when List.exists skips_the_switch unnamed -> + Default lam + | _ -> sw_blocks_default + in + let null_guard = + match (sw_num_default, blocks_default) with + | Default _, Default _ -> + List.exists + (fun (literal : Variant_runtime.literal_tag) -> + literal = Null && skips_the_switch literal) + unnamed + | _ -> false + in + let unnamed = + match (sw_num_default, blocks_default) with + | Default lam, Default _ -> + Ext_list.filter_map unnamed (fun literal -> + if skips_the_switch literal then None + else Some (Variant_runtime.Literal literal, lam)) + | Default lam, (Compiled _ | Complete | NonComplete) -> + List.map + (fun literal -> (Variant_runtime.Literal literal, lam)) + unnamed + | (Compiled _ | Complete | NonComplete), _ -> [] + in + let literal_arms = + match use_compile_literal_cases sw_consts with + | Some arms -> arms @ unnamed + | None -> assert false + in + let payload = + Compiled + (fun cxt -> + compile_cases ~untagged ~tag_name ~null_guard ~cxt + ~switch_exp:e ~block_cases ~default:blocks_default + sw_blocks) + in + if List.length literal_arms <= 2 then + (* An [if] per body, testing its literals with [===] *) + let rec group = function + | [] -> [] + | (tag, lam) :: rest -> + let same, others = + List.partition + (fun (_, other) -> Lambda.eq_approx lam other) + rest + in + (tag :: List.map fst same, lam) :: group others + in + let rec chain ~cxt = function + | [] -> ( + match payload with + | Compiled compile -> compile cxt + | Default _ | Complete | NonComplete -> assert false) + | group :: rest -> + compile_general_cases + ~make_exp:(fun tags -> E.tag_type (List.hd tags)) + ~eq_exp:(fun _ x tags _ -> + match tags with + | Some (tag :: tags) -> + List.fold_left + (fun check tag -> + E.or_ check (E.string_equal x (E.tag_type tag))) + (E.string_equal x (E.tag_type tag)) + tags + | Some [] | None -> assert false) + ~cxt + ~switch:(fun ?default:_ ?declaration:_ _ _ -> + assert false) + ~switch_exp:e + ~default: + (match rest with + | [] -> payload + | _ :: _ -> Compiled (fun cxt -> chain ~cxt rest)) + [group] + in + chain ~cxt (group literal_arms) + else + compile_string_cases ~cxt ~switch_exp:e ~default:payload + literal_arms else [ - S.if_ (is_a_literal_case ()) + S.if_ + (E.is_int_tag ~has_null_undefined_other e) (compile_cases ~cxt ~switch_exp:e ~block_cases ~default:sw_num_default sw_consts) ~else_: - (compile_cases ~untagged ~cxt - ~switch_exp: - (if untagged then e else E.tag ~name:tag_name e) + (compile_cases ~cxt ~switch_exp:(E.tag ~name:tag_name e) ~block_cases ~default:sw_blocks_default sw_blocks); ] in @@ -858,103 +979,250 @@ let compile output_prefix = ~switch:(fun ?default ?declaration e clauses -> S.string_switch ?default ?declaration e clauses) ~switch_exp ~default - and compile_untagged_cases ~cxt ~switch_exp ~default ~block_cases - ~has_null_case cases = - let mk_eq (i : Variant_runtime.tag_type option) x j y = - let check = - match (i, j) with - | Some tag_type, _ -> - Ast_untagged_variants.Dynamic_checks.add_runtime_type_check ~tag_type - ~has_null_case ~block_cases (Expr x) (Expr y) - | _, Some tag_type -> - Ast_untagged_variants.Dynamic_checks.add_runtime_type_check ~tag_type - ~has_null_case ~block_cases (Expr y) (Expr x) - | _ -> Ast_untagged_variants.Dynamic_checks.( == ) (Expr x) (Expr y) - in - E.emit_check check - in - let tag_is_not_typeof = function - | Variant_runtime.Payload_shape (InstanceType _) -> true + and compile_untagged_cases ~cxt ~switch_exp ~default ~block_cases ~tag_name + ~null_guard cases = + (* The payload cases of an untagged variant, after its literals: one + [switch (typeof x)] over the primitive kinds, whose default is an [if] + chain over the classes (subclasses first), arrays, functions and + objects. Primitives never reach a class check, and a class instance + never reaches the function or object arm before its own. In a complete + match the last arm is not checked. *) + let is_primitive_tag = function + | Variant_runtime.Payload_shape + (NumberType | StringType | BigintType | BooleanType | SymbolType) -> + true | _ -> false in - let clause_is_not_typeof (tag, _) = tag_is_not_typeof tag in - let switch ?default ?declaration e clauses = - let not_typeof_clauses, typeof_clauses = - List.partition clause_is_not_typeof clauses + let complete = + match default with + | Complete -> true + | Default _ | Compiled _ | NonComplete -> false + in + let switch ?default:compiled_default ?declaration e clauses = + (* [None] in a complete match, where the last arm is not checked. A + value of an incomplete match that no arm takes runs no statement *) + let default = + if complete then None + else Some (Option.value compiled_default ~default:[]) in - let has_object_typeof = - List.exists - (function - | Variant_runtime.Payload_shape ObjectType, _ -> true - | _ -> false) - typeof_clauses + let primitive_clauses, other_clauses = + List.partition (fun (tag, _) -> is_primitive_tag tag) clauses in - (* When there's an ObjectType typeof case, null, arrays and class - instances can incorrectly match it (typeof null === typeof [] === - "object"). Guard against them when they should fall through to - default: null, and the instance cases without an arm of their own. *) - let needs_null_guard = has_object_typeof && has_null_case in - let unmatched_instances = - if not has_object_typeof then [] - else - Ext_list.filter_map block_cases (function - | Variant_runtime.InstanceType instance - when not - (List.exists - (function - | Variant_runtime.Payload_shape (InstanceType i), _ -> - i = instance - | _ -> false) - not_typeof_clauses) -> - Some instance - | _ -> None) + let arm block_type = + List.find_map + (fun (tag, {J.switch_body}) -> + if tag = Variant_runtime.Payload_shape block_type then + Some switch_body + else None) + other_clauses + in + (* A subclass is checked before its superclasses, otherwise the + declaration order decides *) + let rec subclasses_first = function + | [] -> [] + | instances -> + let first = + List.find + (fun i -> + not + (List.exists + (fun j -> Variant_runtime.Instance.is_subclass j ~of_:i) + instances)) + instances + in + first + :: subclasses_first (List.filter (fun i -> i <> first) instances) in let instances = - Ext_list.filter_map block_cases (function - | Variant_runtime.InstanceType i -> Some i - | _ -> None) + subclasses_first + (Ext_list.filter_map block_cases (function + | Variant_runtime.InstanceType i -> Some i + | _ -> None)) + in + let is_class = function + | Variant_runtime.Instance.Class _ -> true + | Array -> false + in + let check_instance i = E.emit_check (IsInstanceOf (i, Expr e)) in + let typeof_is name = E.string_equal (E.typeof e) (E.str name) in + (* [null], when it did not go to the default before *) + let is_object = + if null_guard then E.and_ (typeof_is "object") (E.not (E.is_null e)) + else typeof_is "object" + in + (* [Some body] for an arm, [None] for the default *) + let entries = + List.map + (fun i -> (Some (check_instance i), i, arm (InstanceType i))) + instances + |> List.filter_map (fun (check, i, body) -> + match (body, default) with + | Some body, _ -> Some (check, is_class i, Some body) + | None, Some _ -> Some (check, is_class i, None) + | None, None -> None) + in + (* The tagged blocks of a variant with some untagged constructors are + objects told apart by their tag *) + let tagged_clauses = + List.filter + (function + | Variant_runtime.Literal _, _ -> true + | Payload_shape _, _ -> false) + other_clauses + in + let tagged = + match (tagged_clauses, default) with + | [], _ -> [] + | [(_, {J.switch_body})], None -> + [(Some is_object, false, Some switch_body)] + | _ -> + [ + ( Some is_object, + false, + Some + [ + S.string_switch ?default (E.tag ~name:tag_name e) + tagged_clauses; + ] ); + ] in - let rec build_if_chain remaining_clauses = - match remaining_clauses with - | ( Variant_runtime.Payload_shape (InstanceType instance_type), - {J.switch_body} ) - :: rest -> - S.if_ - (E.emit_check - (Ast_untagged_variants.Dynamic_checks.is_case_instance ~instances - instance_type (Expr e))) - switch_body - ~else_:[build_if_chain rest] - | _ -> ( - let typeof_switch () = - S.string_switch ?default ?declaration (E.typeof e) typeof_clauses + let entries = + entries + @ (match arm FunctionType with + | Some body -> [(Some (typeof_is "function"), false, Some body)] + | None -> []) + @ tagged + @ (match arm ObjectType with + | Some body -> [(Some is_object, false, Some body)] + | None -> []) + @ + match arm UnknownType with + | Some body -> [(None, false, Some body)] + | None -> [] + in + (* Checks leading to the default are needed only before an arm *) + let rec drop_trailing_defaults = function + | [] -> [] + | entries -> ( + match List.rev entries with + | (_, _, None) :: rest -> drop_trailing_defaults (List.rev rest) + | _ -> entries) + in + let entries = drop_trailing_defaults entries in + (* [if (c1) default else if (c2) body else default] is + [if (c2 && !c1) body else default], and [c1] then runs only on + values passing [c2], never on primitives *) + let entries = + match (default, List.rev entries) with + | Some _, (Some check, is_class, Some body) :: rest -> + let rec absorb check = function + | (Some previous, _, None) :: rest -> + absorb (E.and_ check (E.not previous)) rest + | rest -> List.rev ((Some check, is_class, Some body) :: rest) in - let guards = - (if needs_null_guard then [E.is_null e] else []) - @ List.map - (fun instance -> E.emit_check (IsInstanceOf (instance, Expr e))) - unmatched_instances + absorb check rest + | _ -> entries + in + (* Consecutive checks leading to the default share one [if] *) + let rec merge_defaults = function + | (Some c1, class1, None) :: (Some c2, class2, None) :: rest -> + merge_defaults ((Some (E.or_ c1 c2), class1 || class2, None) :: rest) + | entry :: rest -> entry :: merge_defaults rest + | [] -> [] + in + let entries = merge_defaults entries in + (* The last arm of a complete match is not checked *) + let entries, final = + match (default, List.rev entries) with + | Some default, _ -> (entries, Some default) + | None, (_, _, body) :: rest -> (List.rev rest, body) + | None, [] -> (entries, None) + in + let has_class_check = + List.exists (fun (_, is_class, _) -> is_class) entries + in + let rec chain = function + | [] -> Option.value final ~default:[] + | (check, _, body) :: rest -> ( + let body = + Option.value body ~default:(Option.value default ~default:[]) in - let guard = - match guards with - | [] -> None - | first :: rest -> Some (List.fold_left E.or_ first rest) + match check with + | Some check -> [S.if_ check body ~else_:(chain rest)] + | None -> body) + in + let other = chain entries in + (* The primitive kinds of the type without an arm go to the default + directly when the chain has class checks *) + let unmatched_primitives = + match default with + | Some default when has_class_check -> + let kinds = + Ext_list.filter_map block_cases (fun block_type -> + let tag = Variant_runtime.Payload_shape block_type in + if + is_primitive_tag tag + && not (List.exists (fun (t, _) -> t = tag) primitive_clauses) + then Some tag + else None) in - match (guard, default) with - | Some guard, Some default_body -> - S.if_ guard default_body ~else_:[typeof_switch ()] - | Some guard, None -> S.if_ (E.not guard) [typeof_switch ()] - | None, _ -> typeof_switch ()) + Ext_list.mapi kinds (fun index tag -> + let last = index = List.length kinds - 1 in + ( tag, + { + J.switch_body = (if last then default else []); + should_break = + last + && not (S.block_last_is_return_throw_or_continue default); + comment = None; + source_loc = None; + } )) + | Some _ | None -> [] in - build_if_chain not_typeof_clauses + let primitive_clauses = primitive_clauses @ unmatched_primitives in + (* One kind is an [if], more a [switch (typeof x)] *) + let typeof_switch ?default clauses = + match clauses with + | [ + ( Variant_runtime.Payload_shape block_type, + {J.switch_body; should_break} ); + ] + when switch_body <> [] || should_break -> ( + (* Not a clause falling through to the default *) + match Variant_runtime.typeof_name block_type with + | Some name -> + S.if_ ?declaration (typeof_is name) switch_body ?else_:default + | None -> assert false) + | _ -> S.string_switch ?declaration ?default (E.typeof e) clauses + in + match (primitive_clauses, other) with + | [], _ -> ( + match declaration with + | Some (kind, id) -> S.block (S.declare_variable ~kind id :: other) + | None -> S.block other) + | _ :: _, [] -> ( + (* No other arm: in a complete match the last primitive arm is not + checked *) + match List.rev primitive_clauses with + | (_, {J.switch_body}) :: rest when complete -> + typeof_switch ~default:switch_body (List.rev rest) + | _ -> typeof_switch ?default primitive_clauses) + | _ :: _, _ :: _ -> typeof_switch ~default:other primitive_clauses + in + let is_tagged_block = function + | Variant_runtime.Literal _ -> true + | Payload_shape _ -> false in let merge_cases tag1 tag2 = - (* only merge typeof cases, as instanceof cases are pulled out into if-then-else *) - not (tag_is_not_typeof tag1 || tag_is_not_typeof tag2) + (* Only primitive kinds, or tagged blocks, share a switch, and so + bodies *) + (is_primitive_tag tag1 && is_primitive_tag tag2) + || (is_tagged_block tag1 && is_tagged_block tag2) in cases - |> compile_general_cases ~make_exp:E.tag_type ~eq_exp:mk_eq ~cxt ~switch - ~switch_exp ~default ~merge_cases + |> compile_general_cases ~make_exp:E.tag_type + ~eq_exp:(fun _ _ _ _ -> assert false) + ~cxt ~switch ~switch_exp ~default ~merge_cases ~always_switch:true and compile_stringswitch l cases default (lambda_cxt : Lam_compile_context.t) = (* TODO might better optimization according to the number of cases diff --git a/compiler/ml/UntaggedVariants.md b/compiler/ml/UntaggedVariants.md index 01929fe9700..1c6f0cc930d 100644 --- a/compiler/ml/UntaggedVariants.md +++ b/compiler/ml/UntaggedVariants.md @@ -272,71 +272,86 @@ constructor: | `@as(true) LitTrue \| AnyBool(bool)` | `AnyBool(false)` | `AnyBool` | | `@as(null) LitNull \| AnyObject({x: int})` | `LitNull` | `LitNull` | -The "is a literal case" test is the smaller of two equivalent expressions: the -disjunction of `x === literal` over the literal cases, or the conjunction of -the negated payload checks (with a payload check replaced by the literal -disjunction where a literal overlaps it). A `switch` whose arms name no -literal case still tests the literals first when one of them would pass the -check of a payload arm, such as `@as("lit")` beside a `string` arm, so that -it reaches the default arm. - -- Implementation: `lam_compile.ml:compile_switch`, - `ast_untagged_variants.ml:Dynamic_checks.is_a_literal_case`. +The literals are compared with `===`: by one `switch (x)` over the literal +arms, whose default holds the payload dispatch, or, with at most two +literals, by an `if` per arm body. A literal without an arm of its own goes +to the default arm. It gets a `case` leading there when it could pass a +check of the payload dispatch (a string literal beside a `string` arm, any +literal beside an unknown-kind arm) or when the variant has class cases; +otherwise it reaches the default through the payload dispatch, which then +checks its last arm. A `null` literal that only the object check would +accept adds `x !== null` to that check instead (rule 9). + +- Implementation: `lam_compile.ml:compile_switch`. - Tests: `spec_test` rule 7; `tests/tests/src/untagged_variants_heuristic.res` - (choice of expression). + (literals that skip the `switch`). - Shaped by #6125, #7128, #7135. ### 8. Payload cases -The payload arms compile in one of two forms. +The payload arms compile to one `switch (typeof x)` over the arms of +primitive kinds (string, number, bigint, boolean, symbol), an `if` for one +kind, whose default is an `if` chain over the other arms: -- **Two arms, or one arm and a default**: one `if` on the check of the arm - declared first, with the other branch unchecked (rule 10). The object check is - `typeof x === "object"`, followed by `x !== null` when the variant has an - `@as(null)` case, and by `!(x instanceof C)` (`!Array.isArray(x)` for - arrays) for every instance case of the variant. The function check is - followed by `!(x instanceof C)` for every class case. -- **Three or more arms**: an `if` chain of the instance checks, in the - declaration order of the cases, then one `switch (typeof x)` over the other - arms. - -In both forms a value of an instance case never lands in the object or -function case. A class check is followed by `!(x instanceof D)` for every -case whose class `D` is a subclass of it (rule 5), so a subclass instance -never lands in its superclass's case, whatever the declaration order: +1. the instance cases (arrays, tuples and classes), a subclass before its + superclasses (rule 5), otherwise in declaration order; +2. the function case, `typeof x === "function"`; +3. the tagged constructors of a variant with some untagged ones, an object + whose tag a `switch` tells apart; +4. the object case, `typeof x === "object"`; +5. the unknown-kind case, unchecked. ```js -if (v instanceof Animal && !(v instanceof Dog)) { ... } +switch (typeof x) { + case "string": ... + case "number": ... + default: + if (x instanceof Dog) { ... } + else if (x instanceof Animal) { ... } + else if (typeof x === "object") { ... } +} ``` +An instance case without an arm leads to the default arm, so an array or a +class instance never lands in the function or object case. Before the last +checked arm such checks are folded into its check, which then guards them: +`typeof x === "object" && !(x instanceof Date)`. A primitive never reaches a +class check: it is taken by the `switch (typeof x)`, where a primitive kind +of the variant without an arm has a `case` leading to the default when a +class check could follow. In a complete match the last arm is not checked +(rule 10). + A value upcast to the superclass and wrapped in its case lands in the subclass case, as a payload equal to a literal lands in the literal's case -(rule 7). Classes not declared to be related are tested in declaration order. -`instanceof` consults `Symbol.hasInstance`, which is trusted. +(rule 7). `instanceof` consults `Symbol.hasInstance`, which is trusted for +the values that reach the check: objects and functions, and values outside +every case (rule 10). An `int` case is recognized by `typeof x === "number"` and so receives every number, integral or not. +`break` and `continue` in an arm leave or continue the enclosing loop: every +arm placed in a generated `switch` is compiled in a `switch` context, where +they are labeled. + - Implementation: `lam_compile.ml:compile_untagged_cases`, - `compile_general_cases`; - `ast_untagged_variants.ml:Dynamic_checks.add_runtime_type_check`, - `is_case_instance`. + `compile_general_cases`. - Tests: `spec_test` rules 4, 5 and 8 (`instanceName` shows the chain in - declaration order, `objectFirst` both forms); `tests/tests/src/UntaggedVariants.res` - (`AllInstanceofTypes`, `MergeCases`); - `tests/tests/src/untagged_runtime_annotations_test.res` (subclasses, the - function case). + declaration order, `objectFirst` the unchecked last arm); + `tests/tests/src/UntaggedVariants.res` (`AllInstanceofTypes`, + `MergeCases`); `tests/tests/src/untagged_runtime_annotations_test.res` + (subclasses, the function case, a missing class); + `untagged_default_arm_test.res` (`Symbol.hasInstance`, incomplete + matches); `untagged_loop_control_test.res` (`break`, `continue`). - Shaped by #6103, #6383, #6792, #7144, #7149. ### 9. `null` and arrays are not objects -`typeof null` and `typeof []` are `"object"`, and so is the `typeof` of a -class instance. The object case never receives `null` when the variant has an -`@as(null)` case, and never receives a value of another instance case (array, -tuple or class): the two-arm form adds the checks of rule 8, and the -`switch (typeof x)` form is preceded by `x === null`, `Array.isArray(x)` and -`x instanceof C` guards that send those values to the default arm when their -own arm is absent. -A case declared with `@typeOf("object")` +`typeof null` and `typeof []` are `"object"`, and a class instance is an +object or a function. The object case never receives `null` when the variant +has an `@as(null)` case: the literal comparisons run first (rule 7), or the +object check tests `x !== null` when `null` goes to the default arm. Neither +the object nor the function case receives an instance of another case: the +instance checks come first (rule 8). A case declared with `@typeOf("object")` (rule 5) is an object case: without an `@as(null)` case, it receives `null`, as a record case does. @@ -346,34 +361,33 @@ as a record case does. | | all | `null` | `GNull` | | | `GObject(_)`, `_` | `[]`, `null` | `_` | -- Implementation: `lam_compile.ml:compile_untagged_cases` (`needs_null_guard`, - `unmatched_instances`), `Dynamic_checks.add_runtime_type_check`. +- Implementation: `lam_compile.ml:compile_switch` (`null_guard`), + `compile_untagged_cases`. - Tests: `spec_test` rule 9; `UntaggedVariants.res` (`ObjectAndNull`, `Json`); `tests/tests/src/untagged_default_arm_test.res`. - Shaped by #6219, #7303, #8253, #8255, #8279, #8995. ### 10. Values outside every case -Recognition trusts the type. A value that belongs to no case is not rejected: - -- in the two-arm form it lands in the unchecked branch: with - `I(int) | S(string)`, `true` lands in `S`; with - `TDate(Date.t) | TRegExp(RegExp.t)`, `{x: 1}` lands in `TRegExp`; with - `PPromise(promise) | PFloat(float)`, a thenable that is not a - `Promise` lands in `PFloat`; -- in the `switch (typeof x)` form it matches no arm, and the `switch` - completes without running any arm. +Recognition trusts the type. A value that belongs to no case is not +rejected: in a complete match it lands in the arm that is not checked, the +last one of the `if` chain, or the last primitive arm when there is no other +arm. With `I(int) | S(string)`, `true` lands in `S`; with +`TDate(Date.t) | TRegExp(RegExp.t)`, `{x: 1}` lands in `TRegExp`; with +`PPromise(promise) | PFloat(float)`, the float case is checked, so a +thenable that is not a `Promise` lands in `PPromise`. A value from another JavaScript realm fails every `instanceof` check and is recognized the same way (by the semantics of `instanceof`; not tested): recognition is local to a realm. A class that does not exist where the -`switch` runs makes its check throw, for every value: the instance checks -precede the `typeof` checks, so primitives reach them too. +`switch` runs makes its check throw for every value that reaches it: objects +and functions, and values outside every case. The literals and the +primitives of the variant never reach it. -- Implementation: `lam_compile.ml:compile_general_cases` (a complete match - emits no check for its last clause). -- Tests: `spec_test` rule 10 (two-arm form); `kindName` in - `untagged_variants_spec_test.mjs` shows the `switch` form. +- Implementation: `lam_compile.ml:compile_untagged_cases` (a complete match + emits no check for its last arm). +- Tests: `spec_test` rule 10; `untagged_runtime_annotations_test.res` (a + missing class). ### 11. Constant folding @@ -545,6 +559,5 @@ had to answer, and the answers of rule 5: 9. **Globals.** A shadowed class is read through `globalThis`. A missing class throws when the check runs (rule 10). -Still open: a class imported from a module cannot be named; the `typeof` -checks could precede the instance checks, so that a missing class affects -only objects; and the typed arrays share one type (#8955). +Still open: a class imported from a module cannot be named, and the typed +arrays share one type (#8955). diff --git a/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml index ca7ca6271d0..0cde9d70699 100644 --- a/compiler/ml/ast_untagged_variants.ml +++ b/compiler/ml/ast_untagged_variants.ml @@ -570,128 +570,16 @@ module Dynamic_checks = struct | Not of 'a t | Expr of 'a - let rec size = function - | BinOp (_, x, y) -> 1 + size x + size y - | TagType _ -> 1 - | TypeOf x -> 1 + size x - | IsInstanceOf (_, x) -> 1 + size x - | Not x -> 1 + size x - | Expr _ -> 1 - let bin op x y = BinOp (op, x, y) let tag_type t = TagType t let typeof x = TypeOf x - let str s = Literal (String s) |> tag_type - let is_instance i x = IsInstanceOf (i, x) - let not x = Not x let nil = Literal Null |> tag_type let undefined = Literal Undefined |> tag_type let object_ = Payload_shape ObjectType |> tag_type - let function_ = Payload_shape FunctionType |> tag_type - let string = Payload_shape StringType |> tag_type - let number = Payload_shape NumberType |> tag_type - - let bigint = Payload_shape BigintType |> tag_type - - let boolean = Payload_shape BooleanType |> tag_type - - let symbol = Payload_shape SymbolType |> tag_type - let ( == ) x y = bin EqEqEq x y let ( != ) x y = bin NotEqEq x y let ( ||| ) x y = bin Or x y - let ( &&& ) x y = bin And x y - - let rec is_a_literal_case ~(literal_cases : literal_tag list) ~block_cases - ~list_literal_cases (e : _ t) = - let overlaps p = Ext_list.exists literal_cases p in - let literals_overlaps_with_string () = - overlaps (function - | String _ -> true - | _ -> false) - in - let literals_overlaps_with_number () = - overlaps (function - | Int _ | Float _ -> true - | _ -> false) - in - let literals_overlaps_with_bigint () = - overlaps (function - | BigInt _ -> true - | _ -> false) - in - let literals_overlaps_with_boolean () = - overlaps (function - | Bool _ -> true - | _ -> false) - in - let literals_overlaps_with_object () = - overlaps (function - | Null -> true - | _ -> false) - in - let is_literal_case (t : literal_tag) : _ t = e == tag_type (Literal t) in - let is_not_block_case (c : block_type) : _ t = - match c with - | StringType - when literals_overlaps_with_string () = false (* No overlap *) -> - typeof e != string - | NumberType when literals_overlaps_with_number () = false -> - typeof e != number - | BigintType when literals_overlaps_with_bigint () = false -> - typeof e != bigint - | BooleanType when literals_overlaps_with_boolean () = false -> - typeof e != boolean - | InstanceType i -> not (is_instance i e) - | SymbolType -> typeof e != symbol - | FunctionType -> typeof e != function_ - | ObjectType when literals_overlaps_with_object () = false -> - typeof e != object_ - | ObjectType (* overlap *) -> e == nil ||| (typeof e != object_) - | StringType (* overlap *) - | NumberType (* overlap *) - | BigintType (* overlap *) - | BooleanType (* overlap *) - | UnknownType -> ( - (* We don't know the type of unknown, so we need to express: - this is not one of the literals *) - match literal_cases with - | [] -> - (* this should not happen *) - assert false - | l1 :: others -> - let is_literal_1 = is_literal_case l1 in - Ext_list.fold_right others is_literal_1 (fun literal_n acc -> - is_literal_case literal_n ||| acc)) - in - if list_literal_cases then - let rec mk cases = - match List.rev cases with - | [case] -> is_literal_case case - | case :: rest -> is_literal_case case ||| mk rest - | [] -> assert false - in - mk literal_cases - else - match block_cases with - | [c] -> is_not_block_case c - | c1 :: (_ :: _ as rest) -> - is_not_block_case c1 - &&& is_a_literal_case ~literal_cases ~block_cases:rest - ~list_literal_cases e - | [] -> assert false - - let is_a_literal_case ~literal_cases ~block_cases e = - let with_literal_cases = - is_a_literal_case ~literal_cases ~block_cases ~list_literal_cases:true e - in - let without_literal_cases = - is_a_literal_case ~literal_cases ~block_cases ~list_literal_cases:false e - in - if size with_literal_cases <= size without_literal_cases then - with_literal_cases - else without_literal_cases let is_int_tag ?(has_null_undefined_other = (false, false, false)) (e : _ t) : _ t = @@ -710,40 +598,4 @@ module Dynamic_checks = struct e == nil ||| typeof e != object_ else (* (undefiled + other) || other *) typeof e != object_ - - (* An instance of the case's class [i] that is not an instance of a subclass - of [i] that is a case of its own: [instanceof] holds for superclasses - too. *) - let is_case_instance ~(instances : Instance.t list) i y = - Ext_list.fold_left instances (is_instance i y) (fun check other -> - if Instance.is_subclass other ~of_:i then - check &&& not (is_instance other y) - else check) - - let add_runtime_type_check ~tag_type ~has_null_case - ~(block_cases : block_type list) x y = - let instances = - Ext_list.filter_map block_cases (function - | InstanceType i -> Some i - | _ -> None) - in - (* Instances of a class can be objects or functions, so the cases of - those kinds exclude the class cases *) - let not_one_of_the_instances case = - Ext_list.fold_right instances case (fun i x -> - x &&& not (is_instance i y)) - in - match tag_type with - | Payload_shape - (NumberType | StringType | BigintType | BooleanType | SymbolType) -> - typeof y == x - | Payload_shape FunctionType -> not_one_of_the_instances (typeof y == x) - | Payload_shape ObjectType -> - not_one_of_the_instances - (if has_null_case then typeof y == x &&& (y != nil) else typeof y == x) - | Payload_shape (InstanceType i) -> is_case_instance ~instances i y - | Payload_shape UnknownType -> - (* This should not happen because unknown must be the only non-literal case *) - assert false - | Literal _ -> x end diff --git a/compiler/ml/variant_runtime.ml b/compiler/ml/variant_runtime.ml index e9ae3595894..a2a15b92d7f 100644 --- a/compiler/ml/variant_runtime.ml +++ b/compiler/ml/variant_runtime.ml @@ -126,7 +126,8 @@ type matching_facts = { standard [TAG] field. *) block_types: block_type list; (** Runtime shapes of constructors represented directly by their - payload. Tagged object constructors do not appear here. *) + payload, in declaration order. Tagged object constructors do not + appear here. *) literal_tags: literal_tag list; (** Runtime values of all nullary constructors. In an untagged variant these may overlap the values of a payload constructor, as in @@ -226,8 +227,8 @@ let compute_matching_facts ~tag_name (constructors : constructor_case array) : constructors; { tag_name; - block_types = !block_types; - literal_tags = !literal_tags; + block_types = List.rev !block_types; + literal_tags = List.rev !literal_tags; has_null = !has_null; has_undefined = !has_undefined; has_other_literal = !has_other_literal; diff --git a/tests/tests/src/UntaggedVariants.mjs b/tests/tests/src/UntaggedVariants.mjs index df8f7b89be7..3004d9e4b1d 100644 --- a/tests/tests/src/UntaggedVariants.mjs +++ b/tests/tests/src/UntaggedVariants.mjs @@ -21,12 +21,10 @@ function classify2(x) { } function cls(x) { - if (typeof x !== "object") { - if (x === "One") { - return "one"; - } else { - return "two"; - } + if (x === "One") { + return "one"; + } else if (x === "Two") { + return "two"; } else { return "object" + x.y; } @@ -77,12 +75,10 @@ let Truthy = { }; function classify$1(x) { - if (x == null) { - if (x === null) { - return "null"; - } else { - return "undefined"; - } + if (x === null) { + return "null"; + } else if (x === undefined) { + return "undefined"; } else { return "object" + x.name; } @@ -93,12 +89,11 @@ let TwoObjects = { }; function classify$2(x) { - if (x === "A" || x === "B") { - if (x === "A") { - return "a"; - } else { - return "b"; - } + if (x === "A") { + return "a"; + } + if (x === "B") { + return "b"; } console.log(x); return "Unknown"; @@ -109,26 +104,24 @@ let Unknown = { }; function classify$3(x) { - if (x === "A" || x === "D" || x === "B" || x === "C") { - switch (x) { - case "A" : - return "a"; - case "B" : - return "b"; - case "C" : - return "c"; - case "D" : - return "d"; - } - } else { - switch (typeof x) { - case "string" : - return "string"; - case "number" : - return "int"; - case "object" : - return "Object" + x.name; - } + switch (x) { + case "A" : + return "a"; + case "B" : + return "b"; + case "C" : + return "c"; + case "D" : + return "d"; + default: + switch (typeof x) { + case "string" : + return "string"; + case "number" : + return "int"; + default: + return "Object" + x.name; + } } } @@ -142,7 +135,7 @@ function classify$4(x) { return "string"; case "number" : return "int"; - case "object" : + default: return "Object" + x.name; } } @@ -152,16 +145,17 @@ let OnlyBlocks = { }; function classify$5(x) { - if (Array.isArray(x)) { - return "array"; - } switch (typeof x) { case "string" : return "string"; case "number" : return "int"; - case "object" : - return "Object" + x.name; + default: + if (Array.isArray(x)) { + return "array"; + } else { + return "Object" + x.name; + } } } @@ -170,39 +164,38 @@ let WithArray = { }; function classify$6(x) { - if (x === false || x === null || x === true) { - switch (x) { - case false : - return "JSONFalse"; - case true : - return "JSONTrue"; - case null : - return "JSONNull"; - } - } else { - if (Array.isArray(x)) { - return { - TAG: "JSONArray", - _0: x - }; - } - switch (typeof x) { - case "string" : - return { - TAG: "JSONString", - _0: x - }; - case "number" : - return { - TAG: "JSONNumber", - _0: x - }; - case "object" : - return { - TAG: "JSONObject", - _0: x - }; - } + switch (x) { + case false : + return "JSONFalse"; + case true : + return "JSONTrue"; + case null : + return "JSONNull"; + default: + switch (typeof x) { + case "string" : + return { + TAG: "JSONString", + _0: x + }; + case "number" : + return { + TAG: "JSONNumber", + _0: x + }; + default: + if (Array.isArray(x)) { + return { + TAG: "JSONArray", + _0: x + }; + } else { + return { + TAG: "JSONObject", + _0: x + }; + } + } } } @@ -231,9 +224,6 @@ let TrickyNested = { }; function checkEnum(e) { - if (e !== "One" && e !== "Three" && e !== "Two") { - return "Something else..." + e; - } switch (e) { case "One" : return "One!"; @@ -241,6 +231,8 @@ function checkEnum(e) { return "Two"; case "Three" : return "Threeeee"; + default: + return "Something else..." + e; } } @@ -249,9 +241,6 @@ let OverlapString = { }; function checkEnum$1(e) { - if (e !== 1.0 && e !== "Three" && e !== "Two") { - return "Something else..."; - } switch (e) { case 1.0 : return "One!"; @@ -259,6 +248,8 @@ function checkEnum$1(e) { return "Two"; case "Three" : return "Threeeee"; + default: + return "Something else..."; } } @@ -267,9 +258,6 @@ let OverlapNumber = { }; function checkEnum$2(e) { - if (e !== null && typeof e === "object") { - return "Object..."; - } switch (e) { case null : return "One!"; @@ -277,6 +265,8 @@ function checkEnum$2(e) { return "Two"; case "Three" : return "Threeeee"; + default: + return "Object..."; } } @@ -297,10 +287,10 @@ let RecordIsObject = { }; function classify$8(v) { - if (typeof v === "object" && !Array.isArray(v)) { - return v.x; - } else { + if (Array.isArray(v)) { return v[0]; + } else { + return v.x; } } @@ -354,12 +344,10 @@ let OptionUnboxingHeuristic = { function classify$9(v) { if (Array.isArray(v)) { return v[0]; - } - switch (typeof v) { - case "object" : - return v.x; - case "function" : - return v(3); + } else if (typeof v === "function") { + return v(3); + } else { + return v.x; } } @@ -383,27 +371,23 @@ function check$1(s) { let match = s[0]; if (match === true) { let match$1 = s[1]; - if (match$1 === undefined || match$1 === null || match$1 === false || match$1 === true) { - if (match$1 === false) { - let match$2 = s[2]; - if (Array.isArray(match$2)) { - if (match$2.length !== 2) { - console.log("Nope..."); - return; - } - let match$3 = match$2[0]; - if (typeof match$3 === "string") { - if (match$3 === "My name is") { - let match$4 = match$2[1]; - if (typeof match$4 === "number") { - if (match$4 !== 10) { - console.log("Nope..."); - } else { - console.log("yup"); - } - return; + if (match$1 === false) { + let match$2 = s[2]; + if (Array.isArray(match$2)) { + if (match$2.length !== 2) { + console.log("Nope..."); + return; + } + let match$3 = match$2[0]; + if (typeof match$3 === "string") { + if (match$3 === "My name is") { + let match$4 = match$2[1]; + if (typeof match$4 === "number") { + if (match$4 !== 10) { + console.log("Nope..."); + } else { + console.log("yup"); } - console.log("Nope..."); return; } console.log("Nope..."); @@ -417,18 +401,14 @@ function check$1(s) { } console.log("Nope..."); return; - } else { - console.log("Nope..."); - return; } - } else { console.log("Nope..."); return; } - } else { console.log("Nope..."); return; } + console.log("Nope..."); } let ComplexPattern = { @@ -437,26 +417,21 @@ let ComplexPattern = { }; async function getUserName(u) { - if (u instanceof Promise) { + if (typeof u === "string") { + return u; + } else if (u instanceof Promise) { return (await u).name; - } - switch (typeof u) { - case "object" : - return u.name; - case "string" : - return u; + } else { + return u.name; } } async function awaitUser(u) { - if (u instanceof Promise) { + if (typeof u === "string" || !(u instanceof Promise)) { + return "dummy"; + } else { return (await u).name; } - switch (typeof u) { - case "object" : - case "string" : - return "dummy"; - } } let PromiseSync = { @@ -465,31 +440,27 @@ let PromiseSync = { }; async function classify$10(a) { - if (a === "test" || a === 12) { - if (a === "test") { - console.log("testing"); - return; - } + if (a === "test") { + console.log("testing"); + return; + } + if (a === 12) { console.log(12); return; - } else { - if (Array.isArray(a)) { - console.log(a.join("-")); - return; - } - if (a instanceof Promise) { - console.log(await a); - return; - } - switch (typeof a) { - case "string" : - console.log(a); - return; - case "object" : - console.log(a.userName); - return; - } } + if (typeof a === "string") { + console.log(a); + return; + } + if (Array.isArray(a)) { + console.log(a.join("-")); + return; + } + if (a instanceof Promise) { + console.log(await a); + return; + } + console.log(a.userName); } let Arr = { @@ -497,6 +468,10 @@ let Arr = { }; async function classifyAll(t) { + if (typeof t === "string") { + console.log(t); + return; + } if (Array.isArray(t)) { console.log(t.join("-")); return; @@ -517,7 +492,7 @@ async function classifyAll(t) { console.log(t.name); return; } - if (t instanceof Blob && !(t instanceof File)) { + if (t instanceof Blob) { console.log(t.size); return; } @@ -589,14 +564,7 @@ async function classifyAll(t) { console.log("WeakMap"); return; } - switch (typeof t) { - case "string" : - console.log(t); - return; - case "object" : - console.log(t.userName); - return; - } + console.log(t.userName); } let AllInstanceofTypes = { @@ -604,13 +572,12 @@ let AllInstanceofTypes = { }; function test(t) { - switch (typeof t) { - case "object" : - return t["Hello"]; - case "string" : - return t; - case "function" : - return t(); + if (typeof t === "string") { + return t; + } else if (typeof t === "function") { + return t(); + } else { + return t["Hello"]; } } @@ -631,17 +598,11 @@ function shareEquivalentStringActions(x) { } function can_merge(x) { - if (Array.isArray(x)) { - return "do not merge"; - } - if (x instanceof Date) { + if (typeof x === "boolean" || !(Array.isArray(x) || x instanceof Date)) { + return "merge"; + } else { return "do not merge"; } - switch (typeof x) { - case "boolean" : - case "object" : - return "merge"; - } } function shareAlphaEquivalentStringActions(value) { @@ -665,6 +626,9 @@ function shareAlphaEquivalentStringActions(value) { } function preserveDiscriminatorGroups(x) { + if (typeof x === "boolean") { + return; + } if (Array.isArray(x)) { while (keepGoing()) { sideEffect(); @@ -677,15 +641,9 @@ function preserveDiscriminatorGroups(x) { }; return; } - switch (typeof x) { - case "boolean" : - return; - case "object" : - while (keepGoing()) { - sideEffect(); - }; - return; - } + while (keepGoing()) { + sideEffect(); + }; } let MergeCases = { diff --git a/tests/tests/src/pm_opt_fields_mixed_test.mjs b/tests/tests/src/pm_opt_fields_mixed_test.mjs index 05b2bfb58df..7635a10af32 100644 --- a/tests/tests/src/pm_opt_fields_mixed_test.mjs +++ b/tests/tests/src/pm_opt_fields_mixed_test.mjs @@ -136,12 +136,8 @@ function withU(v) { function stringOrOther(r) { let s = r.u; if (s !== undefined) { - if (s == null) { - if (s === undefined) { - return "other"; - } else { - return "null"; - } + if (s === null) { + return "null"; } else if (typeof s === "string") { return s; } else { @@ -158,13 +154,9 @@ function objectOrOther(r) { return "other"; } let tmp = Primitive_option.valFromOption(match); - if (tmp == null) { - if (tmp === undefined) { - return "undefined"; - } else { - return "other"; - } - } else if (typeof tmp === "string") { + if (tmp === undefined) { + return "undefined"; + } else if (tmp === null || typeof tmp === "string") { return "other"; } else { return "object"; diff --git a/tests/tests/src/unboxed_variant_fold_test.mjs b/tests/tests/src/unboxed_variant_fold_test.mjs index 2e1a13ff3c3..686732a8afe 100644 --- a/tests/tests/src/unboxed_variant_fold_test.mjs +++ b/tests/tests/src/unboxed_variant_fold_test.mjs @@ -28,12 +28,10 @@ function pureName(v) { } function optName(v) { - if (v == null) { - if (v === null) { - return "null"; - } else { - return "undef"; - } + if (v === null) { + return "null"; + } else if (v === undefined) { + return "undef"; } else { return "obj"; } @@ -58,12 +56,10 @@ function answerName(v) { } function mixedName(v) { - if (v === false || v === null) { - if (v === false) { - return "off"; - } else { - return "unset"; - } + if (v === false) { + return "off"; + } else if (v === null) { + return "unset"; } else if (typeof v === "boolean") { if (v) { return "toggle true"; @@ -148,12 +144,10 @@ function wideName(value) { } function numberOrBigintName(value) { - if (typeof value !== "string") { - if (value === 1) { - return "number"; - } else { - return "bigint"; - } + if (value === 1) { + return "number"; + } else if (value === 1n) { + return "bigint"; } else { return value; } diff --git a/tests/tests/src/untagged_builtin_alias_test.mjs b/tests/tests/src/untagged_builtin_alias_test.mjs index fbaf95ceb5b..8346c5a56a1 100644 --- a/tests/tests/src/untagged_builtin_alias_test.mjs +++ b/tests/tests/src/untagged_builtin_alias_test.mjs @@ -4,14 +4,12 @@ import * as Mocha from "mocha"; import * as Test_utils from "./test_utils.mjs"; function kind(value) { - if (Array.isArray(value)) { + if (typeof value === "string") { + return value; + } else if (Array.isArray(value)) { return "pair"; - } - switch (typeof value) { - case "object" : - return "entries"; - case "string" : - return value; + } else { + return "entries"; } } diff --git a/tests/tests/src/untagged_default_arm_test.mjs b/tests/tests/src/untagged_default_arm_test.mjs index 49ddffd59e1..cadbdab5351 100644 --- a/tests/tests/src/untagged_default_arm_test.mjs +++ b/tests/tests/src/untagged_default_arm_test.mjs @@ -3,55 +3,114 @@ import * as Mocha from "mocha"; import * as Test_utils from "./test_utils.mjs"; +globalThis.UntaggedAnyValue = class AnyValue { + static [Symbol.hasInstance]() { return true } +} +; + function id(x) { return x; } function objectOrString(value) { - if (value instanceof RegExp || value instanceof Date) { + if (typeof value === "string") { + return "S"; + } else if (typeof value === "object" && !(value instanceof RegExp) && !(value instanceof Date)) { + return "O"; + } else { return "other"; } - switch (typeof value) { - case "object" : - return "O"; - case "string" : - return "S"; - default: - return "other"; - } } function textOrRecord(value) { if (value === "lit") { return "other"; + } else if (typeof value === "string") { + return "text"; + } else if (typeof value === "object") { + return "record"; + } else { + return "other"; } - switch (typeof value) { - case "string" : - return "text"; - case "object" : - return "record"; +} + +function twoArmsKind(value) { + if (typeof value === "string") { + return "name"; + } else { + return "any"; + } +} + +function withLiteralsKind(value) { + switch (value) { + case 1 : + return "one"; + case 2 : + return "two"; + case 3 : + return "three"; + case 4 : + return "four"; + case 5 : + return "five"; default: + if (typeof value === "string") { + return "name"; + } else { + return "any"; + } + } +} + +function pair(a, b) { + let exit = 0; + if (typeof a === "string") { + if (typeof b === "object" && b !== null && !Array.isArray(b)) { + return "string, object"; + } else { return "other"; + } + } + exit = 2; + if (exit === 2 && typeof b === "object" && b !== null && !Array.isArray(b)) { + return "any, object"; + } + if (typeof a === "number") { + return "number, any"; + } else { + return "other"; } } Mocha.describe("Untagged_default_arm_test", () => { Mocha.test("an instance handled by the default is not an object case", () => { - Test_utils.eq("File \"untagged_default_arm_test.res\", line 31, characters 7-14", "other", objectOrString(id(new Date()))); - Test_utils.eq("File \"untagged_default_arm_test.res\", line 32, characters 7-14", "other", objectOrString(id(/a/))); - Test_utils.eq("File \"untagged_default_arm_test.res\", line 33, characters 7-14", "O", objectOrString(id({ + Test_utils.eq("File \"untagged_default_arm_test.res\", line 81, characters 7-14", "other", objectOrString(id(new Date()))); + Test_utils.eq("File \"untagged_default_arm_test.res\", line 82, characters 7-14", "other", objectOrString(id(/a/))); + Test_utils.eq("File \"untagged_default_arm_test.res\", line 83, characters 7-14", "O", objectOrString(id({ x: 1 }))); - Test_utils.eq("File \"untagged_default_arm_test.res\", line 34, characters 7-14", "S", objectOrString(id("s"))); - Test_utils.eq("File \"untagged_default_arm_test.res\", line 35, characters 7-14", "other", objectOrString(id(1))); + Test_utils.eq("File \"untagged_default_arm_test.res\", line 84, characters 7-14", "S", objectOrString(id("s"))); + Test_utils.eq("File \"untagged_default_arm_test.res\", line 85, characters 7-14", "other", objectOrString(id(1))); }); Mocha.test("a literal handled by the default is not a string case", () => { - Test_utils.eq("File \"untagged_default_arm_test.res\", line 39, characters 7-14", "other", textOrRecord(id("lit"))); - Test_utils.eq("File \"untagged_default_arm_test.res\", line 40, characters 7-14", "text", textOrRecord(id("lit2"))); - Test_utils.eq("File \"untagged_default_arm_test.res\", line 41, characters 7-14", "record", textOrRecord(id({ + Test_utils.eq("File \"untagged_default_arm_test.res\", line 89, characters 7-14", "other", textOrRecord(id("lit"))); + Test_utils.eq("File \"untagged_default_arm_test.res\", line 90, characters 7-14", "text", textOrRecord(id("lit2"))); + Test_utils.eq("File \"untagged_default_arm_test.res\", line 91, characters 7-14", "record", textOrRecord(id({ x: 1 }))); - Test_utils.eq("File \"untagged_default_arm_test.res\", line 42, characters 7-14", "other", textOrRecord(id(1))); + Test_utils.eq("File \"untagged_default_arm_test.res\", line 92, characters 7-14", "other", textOrRecord(id(1))); + }); + Mocha.test("primitives skip class checks in the two-arm form", () => Test_utils.eq("File \"untagged_default_arm_test.res\", line 96, characters 7-14", "name", twoArmsKind(id("a")))); + Mocha.test("a value no arm of an incomplete match takes falls through", () => { + Test_utils.eq("File \"untagged_default_arm_test.res\", line 100, characters 7-14", "number, any", pair(id(1), id([]))); + Test_utils.eq("File \"untagged_default_arm_test.res\", line 101, characters 7-14", "number, any", pair(id(1), id(null))); + Test_utils.eq("File \"untagged_default_arm_test.res\", line 102, characters 7-14", "any, object", pair(id(1), id({}))); + Test_utils.eq("File \"untagged_default_arm_test.res\", line 103, characters 7-14", "other", pair(id("a"), id([]))); + }); + Mocha.test("literals skip class checks", () => { + Test_utils.eq("File \"untagged_default_arm_test.res\", line 107, characters 7-14", "one", withLiteralsKind(id(1))); + Test_utils.eq("File \"untagged_default_arm_test.res\", line 108, characters 7-14", "name", withLiteralsKind(id("a"))); }); }); @@ -59,5 +118,8 @@ export { id, objectOrString, textOrRecord, + twoArmsKind, + withLiteralsKind, + pair, } /* Not a pure module */ diff --git a/tests/tests/src/untagged_default_arm_test.res b/tests/tests/src/untagged_default_arm_test.res index dce3172e6a3..ede910e54aa 100644 --- a/tests/tests/src/untagged_default_arm_test.res +++ b/tests/tests/src/untagged_default_arm_test.res @@ -1,6 +1,12 @@ open Mocha open Test_utils +%%raw(` +globalThis.UntaggedAnyValue = class AnyValue { + static [Symbol.hasInstance]() { return true } +} +`) + @inline(never) let id = x => x // A switch with a default arm keeps the cases it does not name out of the @@ -26,6 +32,50 @@ let textOrRecord = value => | _ => "other" } +// A class whose Symbol.hasInstance accepts every value does not take +// primitives in the two-arm form or in the literal test +@instanceOf("UntaggedAnyValue") type anyValue + +@unboxed +type twoArms = Any(anyValue) | Name(string) + +let twoArmsKind = value => + switch value { + | Any(_) => "any" + | Name(_) => "name" + } + +@unboxed +type withLiterals = + | @as(1) One + | @as(2) Two + | @as(3) Three + | @as(4) Four + | @as(5) Five + | AnyLit(anyValue) + | NameLit(string) + +let withLiteralsKind = value => + switch value { + | One => "one" + | Two => "two" + | Three => "three" + | Four => "four" + | Five => "five" + | AnyLit(_) => "any" + | NameLit(_) => "name" + } + +// The match on [b] is not complete: a value no arm takes falls through to the +// later arms +let pair = (a: JSON.t, b: JSON.t) => + switch (a, b) { + | (String(_), Object(_)) => "string, object" + | (_, Object(_)) => "any, object" + | (Number(_), _) => "number, any" + | _ => "other" + } + describe(__MODULE__, () => { test("an instance handled by the default is not an object case", () => { eq(__LOC__, "other", objectOrString(id(D(Date.make())))) @@ -41,4 +91,20 @@ describe(__MODULE__, () => { eq(__LOC__, "record", textOrRecord(id(Rec({x: 1})))) eq(__LOC__, "other", textOrRecord(id(Count(1)))) }) + + test("primitives skip class checks in the two-arm form", () => { + eq(__LOC__, "name", twoArmsKind(id(Name("a")))) + }) + + test("a value no arm of an incomplete match takes falls through", () => { + eq(__LOC__, "number, any", pair(id(JSON.Number(1.)), id(JSON.Array([])))) + eq(__LOC__, "number, any", pair(id(JSON.Number(1.)), id(JSON.Null))) + eq(__LOC__, "any, object", pair(id(JSON.Number(1.)), id(JSON.Object(dict{})))) + eq(__LOC__, "other", pair(id(JSON.String("a")), id(JSON.Array([])))) + }) + + test("literals skip class checks", () => { + eq(__LOC__, "one", withLiteralsKind(id(One))) + eq(__LOC__, "name", withLiteralsKind(id(NameLit("a")))) + }) }) diff --git a/tests/tests/src/untagged_file_blob_test.mjs b/tests/tests/src/untagged_file_blob_test.mjs index 6fb2f5a1c5d..6b9b7206ffb 100644 --- a/tests/tests/src/untagged_file_blob_test.mjs +++ b/tests/tests/src/untagged_file_blob_test.mjs @@ -4,18 +4,18 @@ import * as Mocha from "mocha"; import * as Test_utils from "./test_utils.mjs"; function kind(upload) { - if (upload instanceof Blob && !(upload instanceof File)) { - return "blob"; - } else { + if (upload instanceof File) { return "file"; + } else { + return "blob"; } } function onlyBlob(upload) { - if (upload instanceof Blob && !(upload instanceof File)) { - return "blob"; - } else { + if (upload instanceof File) { return "other"; + } else { + return "blob"; } } diff --git a/tests/tests/src/untagged_loop_control_test.mjs b/tests/tests/src/untagged_loop_control_test.mjs new file mode 100644 index 00000000000..42ea62f6191 --- /dev/null +++ b/tests/tests/src/untagged_loop_control_test.mjs @@ -0,0 +1,186 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + +import * as Mocha from "mocha"; +import * as Test_utils from "./test_utils.mjs"; + +function scan(values) { + let seen = []; + loop_0: for (let i = 0, i_finish = values.length; i < i_finish; ++i) { + let text = values[i]; + if (text === "stop") { + break; + } + if (text === "skip") { + continue; + } + switch (typeof text) { + case "string" : + switch (text) { + case "break" : + break loop_0; + case "continue" : + continue loop_0; + default: + seen.push(text); + } + break; + case "number" : + if (text < 0) { + break loop_0; + } + seen.push("count"); + break; + default: + if (text instanceof Date) { + continue loop_0; + } + break loop_0; + } + seen.push("."); + } + return seen; +} + +function scanDefault(values) { + let seen = []; + let i = 0; + loop_0: while (i < values.length) { + let value = values[i]; + i = i + 1 | 0; + if (value === "stop") { + break; + } + if (value === "skip") { + continue; + } + switch (typeof value) { + case "string" : + seen.push(value); + break; + case "number" : + continue loop_0; + default: + if (value instanceof Date) { + seen.push("date"); + } else { + continue loop_0; + } + } + seen.push("."); + }; + return seen; +} + +function scanDefaultBreak(values) { + let seen = []; + loop_0: for (let i = 0, i_finish = values.length; i < i_finish; ++i) { + let text = values[i]; + if (text === "stop" || text === "skip") { + break; + } + switch (typeof text) { + case "string" : + seen.push(text); + break; + case "number" : + break loop_0; + default: + if (text instanceof Date) { + seen.push("date"); + } else { + break loop_0; + } + } + } + return seen; +} + +Mocha.describe("Untagged_loop_control_test", () => { + Mocha.test("a literal arm", () => Test_utils.eq("File \"untagged_loop_control_test.res\", line 68, characters 7-14", scan([ + "a", + "skip", + "b", + "stop", + "c" + ]), [ + "a", + ".", + "b", + "." + ])); + Mocha.test("a primitive arm", () => { + Test_utils.eq("File \"untagged_loop_control_test.res\", line 73, characters 6-13", scan([ + "a", + "continue", + 1, + "break", + "c" + ]), [ + "a", + ".", + "count", + "." + ]); + Test_utils.eq("File \"untagged_loop_control_test.res\", line 77, characters 7-14", scan([ + 1, + -1, + "c" + ]), [ + "count", + "." + ]); + }); + Mocha.test("a class and an object arm", () => Test_utils.eq("File \"untagged_loop_control_test.res\", line 81, characters 7-14", scan([ + new Date(), + "a", + { + x: 1 + }, + "c" + ]), [ + "a", + "." + ])); + Mocha.test("a default arm", () => { + Test_utils.eq("File \"untagged_loop_control_test.res\", line 86, characters 6-13", scanDefault([ + 1, + "a", + "skip", + { + x: 1 + }, + new Date(), + "stop", + "c" + ]), [ + "a", + ".", + "date", + "." + ]); + Test_utils.eq("File \"untagged_loop_control_test.res\", line 90, characters 7-14", scanDefaultBreak([ + "a", + 1, + "c" + ]), ["a"]); + Test_utils.eq("File \"untagged_loop_control_test.res\", line 91, characters 7-14", scanDefaultBreak([ + "a", + { + x: 1 + }, + "c" + ]), ["a"]); + Test_utils.eq("File \"untagged_loop_control_test.res\", line 92, characters 7-14", scanDefaultBreak([ + new Date(), + "skip", + "c" + ]), ["date"]); + }); +}); + +export { + scan, + scanDefault, + scanDefaultBreak, +} +/* Not a pure module */ diff --git a/tests/tests/src/untagged_loop_control_test.res b/tests/tests/src/untagged_loop_control_test.res new file mode 100644 index 00000000000..ac373e2b28c --- /dev/null +++ b/tests/tests/src/untagged_loop_control_test.res @@ -0,0 +1,94 @@ +open Mocha +open Test_utils + +// break and continue in the arms of an untagged variant switch leave or +// continue the loop, not the generated switch + +@unboxed +type value = + | @as("stop") Stop + | @as("skip") Skip + | Date(Date.t) + | Text(string) + | Count(float) + | Object({x: int}) + +let scan = (values: array) => { + let seen = [] + for i in 0 to Array.length(values) - 1 { + switch values->Array.getUnsafe(i) { + | Stop => break + | Skip => continue + | Text("break") => break + | Text("continue") => continue + | Text(text) => seen->Array.push(text) + | Count(n) if n < 0. => break + | Count(_) => seen->Array.push("count") + | Date(_) => continue + | Object(_) => break + } + seen->Array.push(".") + } + seen +} + +// Some cases go to the default, which lands both in the typeof switch and +// in the class chain +let scanDefault = (values: array) => { + let seen = [] + let i = ref(0) + while i.contents < Array.length(values) { + let value = values->Array.getUnsafe(i.contents) + i := i.contents + 1 + switch value { + | Stop => break + | Text(text) => seen->Array.push(text) + | Date(_) => seen->Array.push("date") + | _ => continue + } + seen->Array.push(".") + } + seen +} + +let scanDefaultBreak = (values: array) => { + let seen = [] + for i in 0 to Array.length(values) - 1 { + switch values->Array.getUnsafe(i) { + | Text(text) => seen->Array.push(text) + | Date(_) => seen->Array.push("date") + | _ => break + } + } + seen +} + +describe(__MODULE__, () => { + test("a literal arm", () => { + eq(__LOC__, scan([Text("a"), Skip, Text("b"), Stop, Text("c")]), ["a", ".", "b", "."]) + }) + + test("a primitive arm", () => { + eq( + __LOC__, + scan([Text("a"), Text("continue"), Count(1.), Text("break"), Text("c")]), + ["a", ".", "count", "."], + ) + eq(__LOC__, scan([Count(1.), Count(-1.), Text("c")]), ["count", "."]) + }) + + test("a class and an object arm", () => { + eq(__LOC__, scan([Date(Date.make()), Text("a"), Object({x: 1}), Text("c")]), ["a", "."]) + }) + + test("a default arm", () => { + eq( + __LOC__, + scanDefault([Count(1.), Text("a"), Skip, Object({x: 1}), Date(Date.make()), Stop, Text("c")]), + ["a", ".", "date", "."], + ) + eq(__LOC__, scanDefaultBreak([Text("a"), Count(1.), Text("c")]), ["a"]) + eq(__LOC__, scanDefaultBreak([Text("a"), Object({x: 1}), Text("c")]), ["a"]) + eq(__LOC__, scanDefaultBreak([Date(Date.make()), Skip, Text("c")]), ["date"]) + }) +}) diff --git a/tests/tests/src/untagged_runtime_annotations_shadow_test.mjs b/tests/tests/src/untagged_runtime_annotations_shadow_test.mjs index ce74261c117..4dcca29bca1 100644 --- a/tests/tests/src/untagged_runtime_annotations_shadow_test.mjs +++ b/tests/tests/src/untagged_runtime_annotations_shadow_test.mjs @@ -20,16 +20,13 @@ let UntaggedNs = { }; function kind(value) { - if (value instanceof globalThis.UntaggedShadowed) { + if (typeof value === "string") { + return value; + } else if (value instanceof globalThis.UntaggedShadowed) { return "shadowed"; - } - if (value instanceof globalThis.UntaggedNs.Klass) { + } else { return "klass"; } - switch (typeof value) { - case "string" : - return value; - } } Mocha.describe("Untagged_runtime_annotations_shadow_test", () => { diff --git a/tests/tests/src/untagged_runtime_annotations_test.mjs b/tests/tests/src/untagged_runtime_annotations_test.mjs index bb679921349..46c38278985 100644 --- a/tests/tests/src/untagged_runtime_annotations_test.mjs +++ b/tests/tests/src/untagged_runtime_annotations_test.mjs @@ -11,28 +11,20 @@ globalThis.UntaggedCallable = class Callable extends Function {} ; function describePet(pet) { - if (pet instanceof UntaggedAnimal && !(pet instanceof UntaggedDog)) { - return "animal"; - } - if (pet instanceof UntaggedDog) { + if (typeof pet === "string") { + return pet; + } else if (pet instanceof UntaggedDog) { return "dog"; - } - switch (typeof pet) { - case "string" : - return pet; + } else { + return "animal"; } } function onlyAnimal(pet) { - if (pet instanceof UntaggedAnimal && !(pet instanceof UntaggedDog)) { - return "animal"; - } - if (pet instanceof UntaggedDog) { + if (typeof pet === "string" || pet instanceof UntaggedDog) { return "other"; - } - switch (typeof pet) { - case "string" : - return "other"; + } else { + return "animal"; } } @@ -47,10 +39,10 @@ function describeReversed(pet) { let Zoo = {}; function describeAliased(pet) { - if (pet instanceof UntaggedAnimal && !(pet instanceof UntaggedDog)) { - return "animal"; - } else { + if (pet instanceof UntaggedDog) { return "dog"; + } else { + return "animal"; } } @@ -71,87 +63,144 @@ function referenceKind(reference) { } function localeKind(locale) { - if (locale instanceof Intl.Locale) { - return "locale"; - } else { + if (typeof locale === "string") { return locale; + } else { + return "locale"; } } function describePhantom(pet) { - if (pet instanceof UntaggedAnimal && !(pet instanceof UntaggedDog)) { - return "animal"; - } else { + if (pet instanceof UntaggedDog) { return "dog"; + } else { + return "animal"; } } function handlerKind(handler) { - if (typeof handler === "function" && !(handler instanceof UntaggedCallable)) { - return "function"; - } else { + if (handler instanceof UntaggedCallable) { return "callable"; + } else { + return "function"; } } function objectOrNameKind(value) { - if (value instanceof UntaggedDog) { - return "dog"; - } else { + if (typeof value === "string") { return value; + } else { + return "dog"; } } +function id(x) { + return x; +} + +function missingKind(value) { + switch (typeof value) { + case "string" : + return value; + case "number" : + return "count"; + default: + return "missing"; + } +} + +function missingOrDefault(value) { + switch (typeof value) { + case "string" : + return value; + case "number" : + return "other"; + default: + return "missing"; + } +} + +function sharedKind(value) { + let kind; + switch (typeof value) { + case "string" : + kind = "text"; + break; + case "number" : + kind = "other"; + break; + default: + kind = value instanceof Date ? "date" : "other"; + } + return kind + "!"; +} + 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 148, characters 7-14", "animal", describePet(new UntaggedAnimal())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 149, characters 7-14", "dog", describePet(new UntaggedDog())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 150, characters 7-14", "rex", "rex"); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 182, characters 7-14", "animal", describePet(new UntaggedAnimal())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 183, characters 7-14", "dog", describePet(new UntaggedDog())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 184, characters 7-14", "rex", "rex"); }); Mocha.test("a superclass case alone excludes the subclass", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 154, characters 7-14", "animal", onlyAnimal(new UntaggedAnimal())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 155, characters 7-14", "other", onlyAnimal(new UntaggedDog())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 188, characters 7-14", "animal", onlyAnimal(new UntaggedAnimal())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 189, characters 7-14", "other", onlyAnimal(new UntaggedDog())); }); Mocha.test("declaration order does not matter", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 159, characters 7-14", "dog", describeReversed(new UntaggedDog())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 160, characters 7-14", "animal", describeReversed(new UntaggedAnimal())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 193, characters 7-14", "dog", describeReversed(new UntaggedDog())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 194, 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 165, characters 7-14", "dog", describePet(animal)); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 199, characters 7-14", "dog", describePet(animal)); }); Mocha.test("classes reached through a module alias", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 169, characters 7-14", "animal", describeAliased(new UntaggedAnimal())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 170, characters 7-14", "dog", describeAliased(new UntaggedDog())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 203, characters 7-14", "animal", describeAliased(new UntaggedAnimal())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 204, characters 7-14", "dog", describeAliased(new UntaggedDog())); }); Mocha.test("typeOf symbol", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 174, characters 7-14", "symbol", keyKind(Symbol.for("key"))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 175, characters 7-14", "text", "text"); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 208, characters 7-14", "symbol", keyKind(Symbol.for("key"))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 209, characters 7-14", "text", "text"); }); Mocha.test("typeOf string", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 179, characters 7-14", "id", "id"); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 180, characters 7-14", "index", "index"); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 213, characters 7-14", "id", "id"); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 214, characters 7-14", "index", "index"); }); Mocha.test("a class at a dotted path", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 184, characters 7-14", "locale", localeKind(new Intl.Locale("en"))); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 185, characters 7-14", "de", "de"); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 218, characters 7-14", "locale", localeKind(new Intl.Locale("en"))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 219, 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 190, characters 7-14", animal === animal); - Test_utils.ok("File \"untagged_runtime_annotations_test.res\", line 191, characters 7-14", animal === animal); + Test_utils.ok("File \"untagged_runtime_annotations_test.res\", line 224, characters 7-14", animal === animal); + Test_utils.ok("File \"untagged_runtime_annotations_test.res\", line 225, characters 7-14", animal === animal); }); Mocha.test("a phantom type hierarchy", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 195, characters 7-14", "animal", describePhantom(new UntaggedAnimal())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 196, characters 7-14", "dog", describePhantom(new UntaggedDog())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 229, characters 7-14", "animal", describePhantom(new UntaggedAnimal())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 230, 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 200, characters 7-14", "callable", handlerKind(new UntaggedCallable())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 201, characters 7-14", "function", handlerKind(x => x)); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 234, characters 7-14", "callable", handlerKind(new UntaggedCallable())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 235, characters 7-14", "function", handlerKind(x => x)); }); Mocha.test("a class declared over an object type", () => { - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 205, characters 7-14", "dog", objectOrNameKind(new UntaggedDog())); - Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 206, characters 7-14", "rex", "rex"); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 239, characters 7-14", "dog", objectOrNameKind(new UntaggedDog())); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 240, characters 7-14", "rex", "rex"); + }); + Mocha.test("primitive cases are tested before class checks", () => { + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 244, characters 7-14", "a", missingKind(id("a"))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 245, 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 249, characters 7-14", "a", missingOrDefault(id("a"))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 250, 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 254, characters 7-14", "date!", sharedKind(id(new Date()))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 255, characters 7-14", "other!", sharedKind(id({ + x: 1 + }))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 256, characters 7-14", "text!", sharedKind(id("a"))); + Test_utils.eq("File \"untagged_runtime_annotations_test.res\", line 257, characters 7-14", "other!", sharedKind(id(1))); }); }); @@ -170,5 +219,9 @@ export { describePhantom, handlerKind, objectOrNameKind, + id, + missingKind, + missingOrDefault, + sharedKind, } /* Not a pure module */ diff --git a/tests/tests/src/untagged_runtime_annotations_test.res b/tests/tests/src/untagged_runtime_annotations_test.res index d7e53b83cfa..37ec02e2d09 100644 --- a/tests/tests/src/untagged_runtime_annotations_test.res +++ b/tests/tests/src/untagged_runtime_annotations_test.res @@ -143,6 +143,40 @@ let objectOrNameKind = value => | ObjectName(name) => name } +@inline(never) let id = x => x + +// No class of this name exists at run time +@instanceOf("UntaggedMissingClass") type missing + +@unboxed +type withMissing = Missing(missing) | Text(string) | Count(float) + +let missingKind = value => + switch value { + | Missing(_) => "missing" + | Text(text) => text + | Count(_) => "count" + } + +@unboxed +type shared = SharedDate(Date.t) | SharedObject({x: int}) | SharedText(string) | SharedCount(float) + +let missingOrDefault = value => + switch value { + | Missing(_) => "missing" + | Text(text) => text + | _ => "other" + } + +let sharedKind = value => { + let kind = switch value { + | SharedDate(_) => "date" + | SharedText(_) => "text" + | _ => "other" + } + kind ++ "!" +} + describe(__MODULE__, () => { test("a subclass case is not taken for its superclass", () => { eq(__LOC__, "animal", describePet(Animal(makeAnimal()))) @@ -205,4 +239,21 @@ describe(__MODULE__, () => { eq(__LOC__, "dog", objectOrNameKind(ObjectDog(makeObjectDog()))) eq(__LOC__, "rex", objectOrNameKind(ObjectName("rex"))) }) + + test("primitive cases are tested before class checks", () => { + eq(__LOC__, "a", missingKind(id(Text("a")))) + eq(__LOC__, "count", missingKind(id(Count(1.)))) + }) + + test("a primitive without an arm skips class checks", () => { + eq(__LOC__, "a", missingOrDefault(id(Text("a")))) + eq(__LOC__, "other", missingOrDefault(id(Count(1.)))) + }) + + test("a default shared by a primitive and an object case", () => { + eq(__LOC__, "date!", sharedKind(id(SharedDate(Date.make())))) + eq(__LOC__, "other!", sharedKind(id(SharedObject({x: 1})))) + eq(__LOC__, "text!", sharedKind(id(SharedText("a")))) + eq(__LOC__, "other!", sharedKind(id(SharedCount(1.)))) + }) }) diff --git a/tests/tests/src/untagged_variants_spec_test.mjs b/tests/tests/src/untagged_variants_spec_test.mjs index 135972012df..cd70cf0e170 100644 --- a/tests/tests/src/untagged_variants_spec_test.mjs +++ b/tests/tests/src/untagged_variants_spec_test.mjs @@ -28,10 +28,12 @@ function kindName(v) { return "bigint"; case "boolean" : return "bool"; - case "function" : - return "function"; - case "object" : - return "object"; + default: + if (typeof v === "function") { + return "function"; + } else { + return "object"; + } } } @@ -44,57 +46,44 @@ function tupleName(v) { } function aliasDictName(v) { - if (typeof v === "object" && !Array.isArray(v)) { - return "object"; - } else { + if (Array.isArray(v)) { return "array"; + } else { + return "object"; } } function instanceName(v) { - if (v instanceof Date) { + if (typeof v === "string") { + return "string"; + } else if (v instanceof Date) { return "Date"; - } - if (v instanceof RegExp) { + } else if (v instanceof RegExp) { return "RegExp"; - } - if (v instanceof Promise) { + } else if (v instanceof Promise) { return "Promise"; - } - if (v instanceof Map) { + } else if (v instanceof Map) { return "Map"; - } - if (v instanceof Set) { + } else if (v instanceof Set) { return "Set"; - } - if (v instanceof WeakMap) { + } else if (v instanceof WeakMap) { return "WeakMap"; - } - if (v instanceof WeakSet) { + } else if (v instanceof WeakSet) { return "WeakSet"; - } - if (v instanceof ArrayBuffer) { + } else if (v instanceof ArrayBuffer) { return "ArrayBuffer"; - } - if (v instanceof DataView) { + } else if (v instanceof DataView) { return "DataView"; - } - if (v instanceof Float64Array) { + } else { return "Float64Array"; } - switch (typeof v) { - case "string" : - return "string"; - } } function unknownName(v) { - if (v === null || v === "none") { - if (v === null) { - return "null"; - } else { - return "none"; - } + if (v === null) { + return "null"; + } else if (v === "none") { + return "none"; } else { return "list"; } @@ -133,10 +122,10 @@ function overlapNullName(v) { } function objectFirstName(v) { - if (typeof v === "object" && !(v instanceof Date)) { - return "object"; - } else { + if (v instanceof Date) { return "Date"; + } else { + return "object"; } } @@ -175,10 +164,10 @@ function twoInstancesName(v) { } function promiseOrFloatName(v) { - if (v instanceof Promise) { - return "promise"; - } else { + if (typeof v === "number") { return "float"; + } else { + return "promise"; } } @@ -351,7 +340,7 @@ Mocha.describe("Untagged_variants_spec_test", () => { x: 1 }), "RegExp"); let thenable = ({then: (resolve) => resolve(1)}); - Test_utils.eq("File \"untagged_variants_spec_test.res\", line 320, characters 7-14", promiseOrFloatName(thenable), "float"); + Test_utils.eq("File \"untagged_variants_spec_test.res\", line 320, characters 7-14", promiseOrFloatName(thenable), "promise"); }); Mocha.test("rule 12: option of an untagged variant", () => { Test_utils.eq("File \"untagged_variants_spec_test.res\", line 324, characters 7-14", someWithNull(null), null); diff --git a/tests/tests/src/untagged_variants_spec_test.res b/tests/tests/src/untagged_variants_spec_test.res index e0068d02f5d..b9cf3d08f2c 100644 --- a/tests/tests/src/untagged_variants_spec_test.res +++ b/tests/tests/src/untagged_variants_spec_test.res @@ -317,7 +317,7 @@ describe(__MODULE__, () => { eq(__LOC__, intOrStringName(raw(true)), "string") eq(__LOC__, twoInstancesName(raw({"x": 1})), "RegExp") let thenable = %raw(`{then: (resolve) => resolve(1)}`) - eq(__LOC__, promiseOrFloatName(raw(thenable)), "float") + eq(__LOC__, promiseOrFloatName(raw(thenable)), "promise") }) test("rule 12: option of an untagged variant", () => { diff --git a/tests/tests/src/variantsMatching.mjs b/tests/tests/src/variantsMatching.mjs index a23fbd46a8b..94e99525170 100644 --- a/tests/tests/src/variantsMatching.mjs +++ b/tests/tests/src/variantsMatching.mjs @@ -230,12 +230,10 @@ function plus$2(x, y) { } function kind(x) { - if (x == null) { - if (x === null) { - return "null"; - } else { - return "undefined"; - } + if (x === null) { + return "null"; + } else if (x === undefined) { + return "undefined"; } else { return "present"; } @@ -270,22 +268,24 @@ function isWhyNot(x) { } function plus$3(x, y) { - if (x === null || x === "WhyNotAnotherOne" || x === undefined) { - switch (x) { - case null : - case undefined : - return y; - case "WhyNotAnotherOne" : - break; - } - } else if (y !== null && y !== "WhyNotAnotherOne" && y !== undefined) { - return { - x: x.x + y.x, - y: x.y + y.y - }; - } - if (y !== null && y !== "WhyNotAnotherOne" && y !== undefined) { - return "WhyNotAnotherOne"; + switch (x) { + case null : + case undefined : + return y; + case "WhyNotAnotherOne" : + break; + default: + switch (y) { + case null : + case undefined : + case "WhyNotAnotherOne" : + break; + default: + return { + x: x.x + y.x, + y: x.y + y.y + }; + } } switch (y) { case null : @@ -293,13 +293,12 @@ function plus$3(x, y) { return x; case "WhyNotAnotherOne" : return "WhyNotAnotherOne"; + default: + return "WhyNotAnotherOne"; } } function kind$1(x) { - if (x !== null && x !== "WhyNotAnotherOne" && x !== undefined) { - return "present"; - } switch (x) { case null : return "null"; @@ -307,6 +306,8 @@ function kind$1(x) { return "undefined"; case "WhyNotAnotherOne" : return "whynot"; + default: + return "present"; } } @@ -388,7 +389,7 @@ function classify(x) { } else { return "boolean"; } - case "object" : + default: return "Object" + x.name; } } From 356ef589dcf18fe0c46bd71774d1dc66adea397c Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 24 Oct 2026 10:25:52 +0000 Subject: [PATCH 02/19] Drop literal arms that a complete payload dispatch runs anyway A complete payload dispatch with one body runs it unchecked, so a literal arm with the same body needs no case of its own. JS modified (literal arm equal to the payload arm): Example: @unboxed type rec t = | @as(null) Null | @as(undefined) Undefined | WhyNotAnotherOne | Point({x: int, y: int}) let plus = (x, y) => switch y { | Null | Undefined => x | WhyNotAnotherOne => WhyNotAnotherOne | Point(_) => WhyNotAnotherOne } Before (js): switch (y) { case null : case undefined : return x; case "WhyNotAnotherOne" : return "WhyNotAnotherOne"; default: return "WhyNotAnotherOne"; } After (js): if (y == null) { return x; } else { return "WhyNotAnotherOne"; } Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- compiler/core/lam_compile.ml | 13 +++++++++++++ tests/tests/src/variantsMatching.mjs | 12 ++++-------- 2 files changed, 17 insertions(+), 8 deletions(-) diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index 1356897d238..563a819e980 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -886,6 +886,19 @@ let compile output_prefix = | Some arms -> arms @ unnamed | None -> assert false in + (* A complete payload dispatch with one body runs it unchecked, + so a literal arm with the same body can go there too *) + let literal_arms = + match (blocks_default, sw_blocks) with + | Complete, (_, body) :: rest + when List.for_all + (fun (_, other) -> Lambda.eq_approx body other) + rest -> + List.filter + (fun (_, lam) -> not (Lambda.eq_approx body lam)) + literal_arms + | _ -> literal_arms + in let payload = Compiled (fun cxt -> diff --git a/tests/tests/src/variantsMatching.mjs b/tests/tests/src/variantsMatching.mjs index 94e99525170..5d45bd1d348 100644 --- a/tests/tests/src/variantsMatching.mjs +++ b/tests/tests/src/variantsMatching.mjs @@ -287,14 +287,10 @@ function plus$3(x, y) { }; } } - switch (y) { - case null : - case undefined : - return x; - case "WhyNotAnotherOne" : - return "WhyNotAnotherOne"; - default: - return "WhyNotAnotherOne"; + if (y == null) { + return x; + } else { + return "WhyNotAnotherOne"; } } From 77e70041bb72aa85a9881f1dd6de41bcea825db8 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 24 Oct 2026 10:37:50 +0000 Subject: [PATCH 03/19] Update the gentype example for the untagged dispatch The gentype example matches an untagged variant too; its output follows the new dispatch. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- .../typescript-react-example/src/Unboxed.res.js | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/tests/gentype_tests/typescript-react-example/src/Unboxed.res.js b/tests/gentype_tests/typescript-react-example/src/Unboxed.res.js index 96d724a1a14..b91dfe50ff0 100644 --- a/tests/gentype_tests/typescript-react-example/src/Unboxed.res.js +++ b/tests/gentype_tests/typescript-react-example/src/Unboxed.res.js @@ -12,12 +12,10 @@ function r2Test(x) { function tLength(v) { if (Array.isArray(v)) { return v.length; - } - switch (typeof v) { - case "object" : - return v.x; - case "function" : - return v(0); + } else if (typeof v === "function") { + return v(0); + } else { + return v.x; } } From 2271e3e0d072c6c9fa20aea1d344a3139602d023 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 24 Oct 2026 10:30:19 +0000 Subject: [PATCH 04/19] Let builtin types state their runtime shapes Why: Payload kinds had two sources: the shapes declarations state, and a list of builtin paths in get_block_type_from_typ. Builtins were outside the generic checks, so an annotation could not restate a builtin's kind and an interface could not state it over a builtin implementation. The declarations of `int`, `float`, `bigint`, `string`, `bool`, `dict`, `array` and `promise` in `Predef` state their shapes, and only tuples and function types are classified structurally. `@typeOf("number") type count = int` is a restatement, `@typeOf("string") type t = int` a contradiction, and an interface's `@typeOf("number") type t` accepts `type t = int`. Diagnostic modified (annotation over a builtin): Example: @typeOf("string") type t = int Before (diagnostic): @typeOf on a type abbreviation must describe an abstract type, or a type with the same annotation. The abbreviated type already has a runtime representation the compiler knows, or can be undefined. After (diagnostic): This annotation, @typeOf("string"), contradicts the abbreviated type, whose values are recognized by @typeOf("number"). Diagnostic modified (contradicting annotation): Example: @typeOf("symbol") type sym @typeOf("number") type t = sym Before (diagnostic): This annotation, @typeOf("number"), contradicts the abbreviated type's annotation, @typeOf("symbol"). After (diagnostic): This annotation, @typeOf("number"), contradicts the abbreviated type, whose values are recognized by @typeOf("symbol"). Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- compiler/ml/UntaggedVariants.md | 23 ++++++---- compiler/ml/ast_untagged_variants.ml | 3 +- compiler/ml/predef.ml | 18 ++++++-- compiler/ml/variant_layout.ml | 18 +------- ...nnotation_contradicts_builtin.res.expected | 8 ++++ ...notation_contradicts_manifest.res.expected | 2 +- ...runtime_annotation_contradicts_builtin.res | 1 + .../tests/src/untagged_builtin_alias_test.mjs | 42 +++++++++++++++++-- .../tests/src/untagged_builtin_alias_test.res | 37 ++++++++++++++++ 9 files changed, 118 insertions(+), 34 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/runtime_annotation_contradicts_builtin.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/runtime_annotation_contradicts_builtin.res diff --git a/compiler/ml/UntaggedVariants.md b/compiler/ml/UntaggedVariants.md index 1c6f0cc930d..c67d9951c95 100644 --- a/compiler/ml/UntaggedVariants.md +++ b/compiler/ml/UntaggedVariants.md @@ -95,15 +95,17 @@ into one kind: | a type declared with `@typeOf("k")` | kind `k` | `typeof x === "k"` | | anything else: an abstract type, a type variable, a variant, `list<_>`, an `@unboxed` record | unknown | no check | -The annotations of rule 5 are read first, on the type as written and on each -type it abbreviates. Otherwise the payload type is classified after expanding -abbreviations: `type ints = array` is an array case, and `type name = +The builtin types state their kinds in their declarations, as the +annotations of rule 5 do for declared types. The shape is read from the type +as written and from each type it abbreviates, and a tuple or a function type +is classified after expanding abbreviations: `type ints = array` is an array case, and `type name = string` a string case. A type is never recognized by its name. `@typeOf("number")` is the number kind, and `@typeOf("symbol")` is a kind of its own, with no builtin payload type. `@notUndefined` on an abstract type leaves it unknown. -- Implementation: `variant_layout.ml:get_block_type_from_typ`, - `get_block_type`, `recognized_as`. +- Implementation: `predef.ml` (the builtin shapes), + `variant_layout.ml:get_block_type_from_typ`, `get_block_type`, + `recognized_as`. - Tests: `spec_test` rules 4 (`kinds`, `tuples`, `aliasDict`, `instances`, `unknown`); fixtures `UntaggedConstructorMoreThanOneArg.res`, `UntaggedConstructorAttributeMoreThanOneArg.res`, `UntaggedNonUnary1.res`, @@ -144,7 +146,8 @@ superclass. An annotation on an abbreviation must agree with the abbreviated type. It can refine an abstract type that is not builtin and has no annotation, or repeat -the annotation of the abbreviated type. The type of a functor parameter, of a +what the abbreviated type is recognized by, as `@typeOf("number") type count = +int` does. The type of a functor parameter, of a recursive module being defined, and a locally abstract type `(type a)` are abstract only where they are declared: they stand for another type, so they cannot be refined. Only a private abbreviation can declare a subclass of the @@ -157,8 +160,8 @@ and so would `type dog = phantom` with `type phantom<'a> = animal`. | Declaration | Error | Fixture | | --- | --- | --- | -| `@typeOf("string") type t = option`, `type t<'a> = 'a`, an abbreviation of `unit`, a builtin type, a record or a variant | @typeOf on a type abbreviation must describe an abstract type, ... | `runtime_annotation_on_option.res`, `runtime_annotation_on_type_variable.res` | -| `@typeOf("number") type t = sym` with `@typeOf("symbol") type sym` | This annotation, @typeOf("number"), contradicts the abbreviated type's annotation, @typeOf("symbol"). | `runtime_annotation_contradicts_manifest.res` | +| `@typeOf("string") type t = option`, `type t<'a> = 'a`, an abbreviation of `unit`, `list<_>`, a record or a variant | @typeOf on a type abbreviation must describe an abstract type, ... | `runtime_annotation_on_option.res`, `runtime_annotation_on_type_variable.res` | +| `@typeOf("number") type t = sym` with `@typeOf("symbol") type sym`, or `@typeOf("string") type t = int` | This annotation, @typeOf("number"), contradicts the abbreviated type, whose values are recognized by @typeOf("symbol"). | `runtime_annotation_contradicts_manifest.res`, `runtime_annotation_contradicts_builtin.res` | | `@instanceOf("Date") type date = X.t` in a functor of `X`, or over `(type a)` | @instanceOf cannot describe the type of a functor parameter, ... | `instance_of_functor_parameter.res`, `type_of_locally_abstract_type.res` | | `@instanceOf("Dog") type dog = animal`, or `= phantom` with `type phantom<'a> = animal` | A subclass must be a private abbreviation ... | `instance_of_public_subclass.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` | @@ -495,7 +498,9 @@ Type declarations in messages print the `@as` of nullary and tagged cases. A type for which an interface states a class or `typeof` (rule 5), through its own annotation or the type it abbreviates, must state the same one in the implementation, superclasses included: "Their runtime representations -differ". An interface that states none hides it. The same holds for functor +differ". A builtin type states its kind, so `@typeOf("number") type t` in an +interface accepts `type t = int` (`untagged_builtin_alias_test.res`). An +interface that states none hides it. The same holds for functor arguments, `with type` constraints and module type ascriptions. Within one variant a class is identified by its path, so two types of the same class are one case (rule 6); across a signature the two declarations must also state diff --git a/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml index 0cde9d70699..5b18f1f7df3 100644 --- a/compiler/ml/ast_untagged_variants.ml +++ b/compiler/ml/ast_untagged_variants.ml @@ -149,7 +149,8 @@ let report_error ppf = attribute | RuntimeAnnotationContradictsManifest (outer, inner) -> fprintf ppf - "This annotation, %s, contradicts the abbreviated type's annotation, %s." + "This annotation, %s, contradicts the abbreviated type, whose values are \ + recognized by %s." outer inner | SubclassOfPublicAbbreviation (name, ancestor) -> fprintf ppf diff --git a/compiler/ml/predef.ml b/compiler/ml/predef.ml index 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/variant_layout.ml b/compiler/ml/variant_layout.ml index de2a3e4c1fa..fdf7308cf44 100644 --- a/compiler/ml/variant_layout.ml +++ b/compiler/ml/variant_layout.ml @@ -169,23 +169,9 @@ let get_block_type_from_typ ~env (t : Types.type_expr) : block_type option = match recognized_as ~env t with | Some _ as declared -> declared | None -> ( - (* Builtin types have no declaration to annotate *) + (* Builtin types state their shapes in [Predef]; type expressions other + than constructors have no declaration *) match (Ctype.expand_head env t).desc with - | Tconstr (path, _, _) when Path.same path Predef.path_string -> - Some StringType - | Tconstr (path, _, _) - when Path.same path Predef.path_int || Path.same path Predef.path_float -> - Some NumberType - | Tconstr (path, _, _) when Path.same path Predef.path_bigint -> - Some BigintType - | Tconstr (path, _, _) when Path.same path Predef.path_bool -> - Some BooleanType - | Tconstr (path, _, _) when Path.same path Predef.path_dict -> - Some ObjectType - | Tconstr (path, _, _) when Path.same path Predef.path_array -> - Some (InstanceType Array) - | Tconstr (path, _, _) when Path.same path Predef.path_promise -> - Some (InstanceType (Class {name = "Promise"; ancestors = []})) | Ttuple _ -> Some (InstanceType Array) | Tarrow _ -> Some FunctionType | _ -> None) diff --git a/tests/build_tests/super_errors/expected/runtime_annotation_contradicts_builtin.res.expected b/tests/build_tests/super_errors/expected/runtime_annotation_contradicts_builtin.res.expected new file mode 100644 index 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_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/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/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"))) + }) }) From d1446fb6b8a1e23e396cf726092c13044182bfe2 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 24 Oct 2026 10:40:47 +0000 Subject: [PATCH 05/19] Resolve the literal of a constructor without @as once Why: "A constructor without @as is its name" was re-derived wherever a tag was read: in the matching facts, constant folding, code generation, the duplicate-literal check, coercions and gentype, each with its own `None` case, and `[]` special-cased in several of them. The layout stores every constructor's literal, the name when there is no `@as` and `0` for `[]`. Readers take it as is, and matching compares tags without the widening to an optional literal. Messages that name the declared `@as` read the constructor's annotation. Since the literal is what the value is, `A` and `@as("A") A` now agree across an interface and in a coercion, and constant folding compares any two constructors by their runtime values. Representation modified (constructor tag in the layout): Example: type t = A | @as("b") B Before (layout): A -> {name: "A", literal: None} B -> {name: "B", literal: Some (String "b")} After (layout): A -> {name: "A", literal: String "A"} B -> {name: "B", literal: String "b"} Review: Does this change generated JavaScript? No snapshot changed: the resolved literal is the value every reader computed before. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- compiler/core/js_dump.ml | 8 +--- compiler/core/lam_compile.ml | 29 +++++------- compiler/core/lam_compile_const.ml | 7 +-- .../gentype/translate_type_declarations.ml | 33 +++++++------- compiler/ml/UntaggedVariants.md | 9 ++-- compiler/ml/ast_untagged_variants.ml | 26 ++++++----- compiler/ml/ctype.ml | 10 ++--- compiler/ml/error_message_utils.ml | 5 +-- compiler/ml/lambda.ml | 44 ++++++++----------- compiler/ml/matching.ml | 4 +- compiler/ml/printtyp.ml | 4 +- compiler/ml/typeopt.ml | 2 +- compiler/ml/variant_coercion.ml | 25 +++++------ compiler/ml/variant_layout.ml | 2 +- compiler/ml/variant_runtime.ml | 23 +++------- compiler/ml/variant_runtime.mli | 18 +++----- .../ounit_lambda_constant_tests.ml | 34 +++++++++++--- tests/tests/src/as_constructor_name_test.mjs | 21 +++++++++ tests/tests/src/as_constructor_name_test.res | 28 ++++++++++++ 19 files changed, 180 insertions(+), 152 deletions(-) create mode 100644 tests/tests/src/as_constructor_name_test.mjs create mode 100644 tests/tests/src/as_constructor_name_test.res diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index 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 563a819e980..228e880a2a6 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, [], [], (false, false, false)) @@ -707,10 +706,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) ?(tag_name = Js_dump_lit.tag) @@ -794,9 +791,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 @@ -804,9 +800,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 -> (* A tagged block, an object *) Some Variant_runtime.ObjectType) 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 c67d9951c95..9009e7fb84e 100644 --- a/compiler/ml/UntaggedVariants.md +++ b/compiler/ml/UntaggedVariants.md @@ -55,9 +55,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 @@ -489,7 +489,8 @@ error. An interface and its implementation must agree on `@unboxed`, on `@tag`, on the literal of every nullary case and of every tagged case with a payload, and on the payload kind of every untagged case whose kind the interface -knows. An unknown payload in the interface is its only payload case and is +knows. A case without `@as` has the literal of its name, so `A` and +`@as("A") A` agree, here and in coercions (`as_constructor_name_test.res`). An unknown payload in the interface is its only payload case and is not checked, so it agrees with any payload of the implementation (`untagged_hidden_payload_test.res`). The `@as` of an untagged case with a payload does not change its representation (rule 2) and is not compared. diff --git a/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml index 5b18f1f7df3..47c4d6d2921 100644 --- a/compiler/ml/ast_untagged_variants.ml +++ b/compiler/ml/ast_untagged_variants.ml @@ -370,7 +370,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} @@ -452,20 +452,17 @@ let check_invariant ~is_untagged_def ~(consts : (Location.t * tag) list) in let check_literal ~is_const ~loc (tag : tag) = match tag.literal with - | None -> add_string_literal ~is_const ~loc tag.name - | Some (String s) -> add_string_literal ~is_const ~loc s - | Some (Int i as literal) -> + | String s -> add_string_literal ~is_const ~loc s + | Int i as literal -> add_nonstring_literal ~is_const ~loc literal (string_of_int i) - | Some (Float f as literal) -> - add_nonstring_literal ~is_const ~loc literal f - | Some (BigInt i as literal) -> + | Float f as literal -> add_nonstring_literal ~is_const ~loc literal f + | BigInt i as literal -> add_nonstring_literal ~is_const ~loc literal (i ^ "n") - | Some (Bool b as literal) -> + | Bool b as literal -> add_nonstring_literal ~is_const ~loc literal (if b then "true" else "false") - | Some (Null as literal) -> - add_nonstring_literal ~is_const ~loc literal "null" - | Some (Undefined as literal) -> + | Null as literal -> add_nonstring_literal ~is_const ~loc literal "null" + | Undefined as literal -> add_nonstring_literal ~is_const ~loc literal "undefined" in @@ -532,8 +529,13 @@ let check_invariant ~is_untagged_def ~(consts : (Location.t * tag) list) invariant loc tag.name | Tagged _ -> ())) +(* A constructor without [@as] is represented by its name *) +let declared_tag (cstr : Types.constructor_declaration) = + let name = Ident.name cstr.cd_id in + {name; literal = Option.value cstr.cd_runtime_tag ~default:(String name)} + let get_cstr_loc_tag (cstr : Types.constructor_declaration) = - (cstr.cd_loc, {name = Ident.name cstr.cd_id; literal = cstr.cd_runtime_tag}) + (cstr.cd_loc, declared_tag cstr) let check_tag_field_conflicts (cstrs : Types.constructor_declaration list) = List.iter diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index 51d926eaae2..4c319279edd 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -3580,7 +3580,7 @@ let rec subtype_rec env trace t1 t2 cstrs = Variant_coercion.can_try_coerce_variant_to_primitive_opt (extract_concrete_typedecl_opt env t2) with - | Some (p, _, _, false) -> + | Some (p, _, false) -> (* Not @unboxed *) ( trace, t1, @@ -3590,7 +3590,7 @@ let rec subtype_rec env trace t1 t2 cstrs = (Coercion_target_variant_not_unboxed {variant_name = p; primitive = path}) ) :: cstrs - | Some (p, constructors, _, true) -> + | Some (p, constructors, true) -> if Variant_coercion.variant_has_case_covering_type constructors ~path_is_same_fn:(fun p -> Path.same p path) @@ -3622,12 +3622,12 @@ let rec subtype_rec env trace t1 t2 cstrs = Variant_coercion.can_try_coerce_variant_to_primitive_opt (extract_concrete_typedecl_opt env t1) with - | Some (p, constructors, layout, unboxed) -> + | Some (p, constructors, unboxed) -> let runtime_representation_issues = constructors |> Variant_coercion .variant_has_same_runtime_representation_as_target - ~target_path:path ~unboxed ~layout + ~target_path:path ~unboxed in if List.length runtime_representation_issues <> 0 then ( trace, @@ -3857,7 +3857,7 @@ let rec subtype_rec env trace t1 t2 cstrs = in match Variant_coercion.can_coerce_polyvariant_to_variant ~row_fields - ~variant_constructors ~layout ~unboxed + ~variant_constructors ~unboxed with | Ok _ -> cstrs | Error _ -> diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index 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/lambda.ml b/compiler/ml/lambda.ml index 33443e420e1..e857e7cee7a 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 @@ -888,11 +886,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 @@ -901,7 +894,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. *) @@ -933,8 +926,7 @@ let switch lam (lam_switch : lambda_switch) : t = Ext_list.find_opt lam_switch.sw_consts (fun (key, action) -> match key with | Switch_int ordinal when ordinal = i -> Some action - | Switch_constructor - (Constant {literal = Some (Variant_runtime.Int value)}) + | Switch_constructor (Constant {literal = Variant_runtime.Int value}) when value = i -> Some action | Switch_int _ | Switch_constructor _ -> None) @@ -1016,13 +1008,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 ), @@ -1173,15 +1166,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/printtyp.ml b/compiler/ml/printtyp.ml index 2af6c90d8fe..f163f892c09 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -930,9 +930,7 @@ and tree_of_constructor ?printing_context ~layout ~position cd = | Bool b -> Printf.sprintf "@as(%b)" b | BigInt s -> Printf.sprintf "@as(%sn)" s in - match Variant_runtime.constructor_tag layout position with - | Some d -> Some (as_annotation d) - | None -> None + Option.map as_annotation cd.cd_runtime_tag in let arg () = tree_of_constructor_arguments ?printing_context cd.cd_args in match cd.cd_res with diff --git a/compiler/ml/typeopt.ml b/compiler/ml/typeopt.ml index fce5edc493d..4ad9213b739 100644 --- a/compiler/ml/typeopt.ml +++ b/compiler/ml/typeopt.ml @@ -100,7 +100,7 @@ let rec cannot_contain_undefined ~visiting (typ : Types.type_expr) (env : Env.t) | Variant_runtime.Block (Tagged {tag}) -> (tag, false) | Variant_runtime.Block (Untagged {tag}) -> (tag, true) in - tag.literal <> Some Variant_runtime.Undefined + tag.literal <> Variant_runtime.Undefined && ((not payload_is_unboxed) || match cd.cd_args with diff --git a/compiler/ml/variant_coercion.ml b/compiler/ml/variant_coercion.ml index 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 fdf7308cf44..1dc17d28f80 100644 --- a/compiler/ml/variant_layout.ml +++ b/compiler/ml/variant_layout.ml @@ -198,7 +198,7 @@ let get_block_type ~env (cstr : Types.constructor_declaration) : block_type = let layout_from_type_variant ~(configuration : configuration) ~env (cstrs : Types.constructor_declaration list) : Variant_runtime.layout = let get_block (cstr : Types.constructor_declaration) : block = - let tag = {name = Ident.name cstr.cd_id; literal = cstr.cd_runtime_tag} in + let tag = declared_tag cstr in let tag_name = process_tag_name cstr.cd_attributes in if has_untagged cstr.cd_attributes 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 a2a15b92d7f..61f8f328185 100644 --- a/compiler/ml/variant_runtime.ml +++ b/compiler/ml/variant_runtime.ml @@ -96,10 +96,9 @@ let same_literal_value a b = literal_value_key a = literal_value_key b 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} +type tag = {name: string; literal: literal_tag} (** 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. *) @@ -111,11 +110,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} @@ -208,13 +202,7 @@ let compute_matching_facts ~tag_name (constructors : constructor_case array) : let has_other_literal = ref false 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 + | Constant {literal} -> ( literal_tags := literal :: !literal_tags; match literal with | Null -> has_null := true @@ -260,9 +248,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 93cc06f12c7..8eaf4e7b60e 100644 --- a/compiler/ml/variant_runtime.mli +++ b/compiler/ml/variant_runtime.mli @@ -66,12 +66,9 @@ val same_literal_value : literal_tag -> literal_tag -> 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} @@ -83,10 +80,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 @@ -119,7 +112,10 @@ val get_layout : layout_ref -> layout val matching_facts : layout -> matching_facts val configuration : layout -> configuration val constructor_at : layout -> int -> constructor_case -val constructor_tag : layout -> int -> literal_tag option + +val constructor_tag : layout -> int -> literal_tag +(** The literal of a constant constructor, or of the tag of a tagged one *) + val representation : constructor_reference -> constructor_case val length : layout -> int val num_constants : layout -> int diff --git a/tests/ounit_tests/ounit_lambda_constant_tests.ml b/tests/ounit_tests/ounit_lambda_constant_tests.ml index d1a470144f2..732be64d80a 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 = @@ -147,7 +147,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 @@ -159,7 +160,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); ] ); @@ -191,6 +192,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..6800be087ee --- /dev/null +++ b/tests/tests/src/as_constructor_name_test.mjs @@ -0,0 +1,21 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + +import * as Mocha from "mocha"; +import * as Test_utils from "./test_utils.mjs"; + +let Stated = { + a: "A" +}; + +Mocha.describe("As_constructor_name_test", () => { + Mocha.test("coercion", () => Test_utils.eq("File \"as_constructor_name_test.res\", line 22, characters 7-14", "A", "A")); + Mocha.test("interface", () => Test_utils.eq("File \"as_constructor_name_test.res\", line 26, characters 7-14", "A", "A")); +}); + +let declaredA = "A"; + +export { + declaredA, + Stated, +} +/* Not a pure module */ diff --git a/tests/tests/src/as_constructor_name_test.res b/tests/tests/src/as_constructor_name_test.res new file mode 100644 index 00000000000..678c15d0ba7 --- /dev/null +++ b/tests/tests/src/as_constructor_name_test.res @@ -0,0 +1,28 @@ +open Mocha +open Test_utils + +// A constructor without @as is represented by its name, so `@as("A")` on a +// constructor named A states the same representation + +type named = A | B +type declared = | @as("A") A | B | C + +let declaredA = (A: named :> declared) + +module Stated: { + type t = A | B + let a: t +} = { + type t = | @as("A") A | B + let a = A +} + +describe(__MODULE__, () => { + test("coercion", () => { + eq(__LOC__, declaredA, A) + }) + + test("interface", () => { + eq(__LOC__, Stated.a, Stated.A) + }) +}) From 7fb8da367500c16322999cfd88a8117a90c0350b Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 24 Oct 2026 10:46:32 +0000 Subject: [PATCH 06/19] Allow @notUndefined on type abbreviations Why: `@instanceOf` and `@typeOf` can refine or restate the type an abbreviation stands for, while `@notUndefined` was rejected on every abbreviation, even of an abstract type it could refine. `@notUndefined` on an abbreviation follows the rule of the other annotations: it can refine a type whose representation the compiler does not see, or restate that the type cannot be undefined, keeping a payload kind the type has. The check whether a type can be undefined is shared with interface inclusion (`Typeopt.undefinedness`); `get_unboxed_type_representation` moves to `Ctype` so that `Typedecl` can call it. Diagnostic modified (@notUndefined on an abbreviation): Example: @notUndefined type t = option Before (diagnostic): @notUndefined can only be used on abstract types After (diagnostic): @notUndefined on a type abbreviation must describe an abstract type, or a type with the same annotation. The abbreviated type already has a runtime representation the compiler knows, or can be undefined. Diagnostic modified (@notUndefined on a record): Example: @notUndefined type t = {x: int} Before (diagnostic): @notUndefined can only be used on abstract types After (diagnostic): @notUndefined can only be used on abstract types and type abbreviations, whose runtime representation it describes. JS modified (refined abstract type): Example: type opaque @notUndefined type refined = opaque let wrap = (x: refined) => Some(x) Before (js): error After (js): function wrap(x) { return x; } Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- changes/untagged-declarations.polish.md | 1 + compiler/ml/UntaggedVariants.md | 28 +++++-- compiler/ml/ctype.ml | 32 ++++++++ compiler/ml/ctype.mli | 4 + compiler/ml/includemod.ml | 24 ++---- compiler/ml/typedecl.ml | 80 +++++++------------ compiler/ml/typedecl.mli | 1 - compiler/ml/typeopt.ml | 24 +++++- compiler/ml/typeopt.mli | 11 +++ compiler/ml/variant_layout.ml | 9 ++- .../not_undefined_attribute/demo.res | 2 +- .../not_undefined_attribute/input.js | 8 +- ...valid_attribute_not_undefined.res.expected | 6 +- ...ned_on_functor_parameter_type.res.expected | 11 +++ .../not_undefined_on_option.res.expected | 8 ++ .../invalid_attribute_not_undefined.res | 2 +- ...ot_undefined_on_functor_parameter_type.res | 7 ++ .../fixtures/not_undefined_on_option.res | 1 + tests/tests/src/as_constructor_name_test.res | 2 +- .../src/not_undefined_abbreviation_test.mjs | 46 +++++++++++ .../src/not_undefined_abbreviation_test.res | 41 ++++++++++ 21 files changed, 261 insertions(+), 87 deletions(-) create mode 100644 changes/untagged-declarations.polish.md create mode 100644 tests/build_tests/super_errors/expected/not_undefined_on_functor_parameter_type.res.expected create mode 100644 tests/build_tests/super_errors/expected/not_undefined_on_option.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/not_undefined_on_functor_parameter_type.res create mode 100644 tests/build_tests/super_errors/fixtures/not_undefined_on_option.res create mode 100644 tests/tests/src/not_undefined_abbreviation_test.mjs create mode 100644 tests/tests/src/not_undefined_abbreviation_test.res diff --git a/changes/untagged-declarations.polish.md b/changes/untagged-declarations.polish.md new file mode 100644 index 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/ml/UntaggedVariants.md b/compiler/ml/UntaggedVariants.md index 9009e7fb84e..9714db16b71 100644 --- a/compiler/ml/UntaggedVariants.md +++ b/compiler/ml/UntaggedVariants.md @@ -449,12 +449,22 @@ hold `undefined`. ### 13. `@notUndefined` -`@notUndefined` on an abstract type without a manifest declares that its -values are never `undefined`. It affects only rule 12: `option` of the type, -and of an untagged variant with a payload of the type, is unboxed. It does not -make the type a recognized payload kind (rule 4). On any other type -declaration it is an error, "@notUndefined can only be used on abstract -types". `@instanceOf` and `@typeOf` (rule 5) imply it. +`@notUndefined` on an abstract type declares that its values are never +`undefined`. It affects only rule 12: `option` of the type, and of an +untagged variant with a payload of the type, is unboxed. It does not make the +type a recognized payload kind (rule 4). `@instanceOf` and `@typeOf` (rule 5) +imply it. + +On an abbreviation it follows the rule of rule 5: it can refine a type whose +representation the compiler does not see, such as an abstract type, or +restate that the abbreviated type cannot be `undefined`, as +`@notUndefined type count = int` does, which keeps the kind of `int`. + +| Declaration | Error | Fixture | +| --- | --- | --- | +| `@notUndefined type t = {x: int}`, or on a variant | @notUndefined can only be used on abstract types and type abbreviations, ... | `invalid_attribute_not_undefined.res` | +| `@notUndefined type t = option` | @notUndefined on a type abbreviation must describe an abstract type, ... | `not_undefined_on_option.res`, `tests/build_tests/not_undefined_attribute` | +| `@notUndefined type t = X.t` in a functor of `X` | @notUndefined cannot describe the type of a functor parameter, ... | `not_undefined_on_functor_parameter_type.res` | When an interface declares a type `@notUndefined`, its implementation must be a type that cannot hold `undefined` either, or a type whose representation @@ -467,14 +477,16 @@ differ: the second declaration is @notUndefined, but the first declaration can hold undefined". The same holds for functor arguments and `with type` constraints. -- Implementation: `typedecl.ml:transl_declaration`; +- Implementation: `typedecl.ml:transl_declaration`, + `check_not_undefined_manifest`; `typeopt.ml:undefinedness`; `ast_untagged_variants.ml:has_not_undefined`; `variant_layout.ml:declaration_shape`; `typeopt.ml:type_cannot_contain_undefined`; `includemod.ml:not_undefined_mismatch`. - Tests: `spec_test` rule 13; fixtures `invalid_attribute_not_undefined.res`, `not_undefined_functor_argument.res`, `not_undefined_functor_parameter.res`; - `tests/tests/src/not_undefined_interface_test.res`; + `tests/tests/src/not_undefined_interface_test.res`, + `not_undefined_abbreviation_test.res`; `tests/build_tests/super_errors_multi/fixtures/Cross_not_undefined_option_implementation`; `tests/build_tests/not_undefined_attribute`. - Shaped by #7458, #7464, #8964. diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index 4c319279edd..b1326f398a7 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -4391,3 +4391,35 @@ let get_arity env typ = module For_test = struct let previous_env_is_empty () = !(previous_env ()) == Env.empty end + +(* We use the expand_head_opt version of expand_head to get access + to the manifest type of private abbreviations. *) +let rec get_unboxed_type_representation env ty fuel = + if fuel < 0 then None + else + let ty = repr (expand_head_opt env ty) in + match ty.desc with + | Tconstr (p, args, _) -> ( + match Env.find_type p env with + | exception Not_found -> Some ty + | {type_representation = Boxed} -> Some ty + | { + type_params; + type_kind = + ( Type_record ([{ld_type = ty2; _}], _) + | Type_variant ([{cd_args = Cstr_tuple [ty2]; _}], _) + | Type_variant ([{cd_args = Cstr_record [{ld_type = ty2; _}]; _}], _) ); + } -> + get_unboxed_type_representation env + (apply env type_params ty2 args) + (fuel - 1) + | {type_kind = Type_abstract} -> + None + (* This case can occur when checking a recursive unboxed type + declaration. *) + | _ -> assert false (* only the above can be unboxed *)) + | _ -> Some ty + +let get_unboxed_type_representation env ty = + (* Do not give too much fuel: PR#7424 *) + get_unboxed_type_representation env ty 100 diff --git a/compiler/ml/ctype.mli b/compiler/ml/ctype.mli index 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/includemod.ml b/compiler/ml/includemod.ml index 08f44bbe4ae..fbd64367ad8 100644 --- a/compiler/ml/includemod.ml +++ b/compiler/ml/includemod.ml @@ -63,31 +63,21 @@ let value_descriptions ~loc env cxt subst id vd1 vd2 = (* Inclusion between type declarations *) (* [@notUndefined] lets clients unbox [option] of the type, so the - implementation must be a type that cannot hold [undefined] either. A type - whose representation the compiler does not see, an abstract type (also - through an abbreviation) or a JavaScript object type, has none that - contradicts it. A functor parameter's or a locally abstract type stands - for any type, so it does not count as abstract. *) + implementation must be a type that cannot hold [undefined] either, or one + whose representation the compiler does not see, which has none that + contradicts it. *) let not_undefined_mismatch env id (decl1 : Types.type_declaration) (decl2 : Types.type_declaration) = match decl2.type_shape with | Unstated | Recognized_as _ -> [] - | Never_undefined -> + | Never_undefined -> ( let env = Env.add_type ~check:false id decl1 env in let ty = Btype.newgenty (Tconstr (Pident id, decl1.type_params, ref Mnil)) in - let opaque = - match (Ctype.expand_head_opt env ty).desc with - | Tconstr (path, _, _) -> ( - match Variant_layout.abstractness ~env path with - | Opaque -> true - | Stands_for_another | Not_abstract -> false) - | Tobject _ -> true - | _ -> false - in - if opaque || Typeopt.type_cannot_contain_undefined ty env then [] - else [Includecore.Not_undefined] + match Typeopt.undefinedness env ty with + | Cannot_be_undefined | Unseen -> [] + | Stands_for_another | Can_be_undefined -> [Includecore.Not_undefined]) let type_declarations ~loc env ?(old_env = env) cxt subst id decl1 decl2 = Env.mark_type_used env (Ident.name id) decl1; diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index 55b341f8e0c..9044a61e4be 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -48,7 +48,6 @@ type error = | Bad_fixed_type of string | Unbound_type_var_ext of type_expr * extension_constructor | Varying_anonymous - | Invalid_attribute of string | Bad_immediate_attribute | Bad_unboxed_attribute of string | Nonrec_gadt @@ -119,38 +118,6 @@ let update_type temp_env env id loc = try Ctype.unify env (Ctype.newconstr path params) ty with Ctype.Unify trace -> raise (Error (loc, Type_clash (env, trace)))) -(* We use the Ctype.expand_head_opt version of expand_head to get access - to the manifest type of private abbreviations. *) -let rec get_unboxed_type_representation env ty fuel = - if fuel < 0 then None - else - let ty = Ctype.repr (Ctype.expand_head_opt env ty) in - match ty.desc with - | Tconstr (p, args, _) -> ( - match Env.find_type p env with - | exception Not_found -> Some ty - | {type_representation = Boxed} -> Some ty - | { - type_params; - type_kind = - ( Type_record ([{ld_type = ty2; _}], _) - | Type_variant ([{cd_args = Cstr_tuple [ty2]; _}], _) - | Type_variant ([{cd_args = Cstr_record [{ld_type = ty2; _}]; _}], _) ); - } -> - get_unboxed_type_representation env - (Ctype.apply env type_params ty2 args) - (fuel - 1) - | {type_kind = Type_abstract} -> - None - (* This case can occur when checking a recursive unboxed type - declaration. *) - | _ -> assert false (* only the above can be unboxed *)) - | _ -> Some ty - -let get_unboxed_type_representation env ty = - (* Do not give too much fuel: PR#7424 *) - get_unboxed_type_representation env ty 100 - (* Determine if a type definition defines a fixed type. (PW) *) let is_fixed_type sd = let rec has_row_var sty = @@ -369,20 +336,35 @@ let make_constructor env type_path type_params sargs sret_type = any type variable present in [ty]. *) +(* [@notUndefined] on an abbreviation is a claim about the abbreviated type, + as [@instanceOf] and [@typeOf] are: it can refine a type whose + representation the compiler does not see, or restate that a type cannot + hold [undefined] *) +let check_not_undefined_manifest ~loc ~env (decl : Types.type_declaration) = + match decl.type_manifest with + | Some manifest + when Ast_untagged_variants.has_not_undefined decl.type_attributes -> ( + let error err = raise (Ast_untagged_variants.Error (loc, err)) in + match Typeopt.undefinedness env manifest with + | Cannot_be_undefined | Unseen -> () + | Stands_for_another -> + error (RuntimeAnnotationOnTypeParameter "notUndefined") + | Can_be_undefined -> + error (RuntimeAnnotationOnUnrelatedType "notUndefined")) + | Some _ | None -> () + +let check_manifest_annotations ~loc ~env decl = + Variant_layout.check_manifest_annotation ~loc ~env decl; + check_not_undefined_manifest ~loc ~env decl + let transl_declaration ~type_record_as_object env sdecl id = - (* Check for @notUndefined attribute *) - let has_not_undefined = + if Ast_untagged_variants.has_not_undefined sdecl.ptype_attributes - in - (if has_not_undefined then - match (sdecl.ptype_kind, sdecl.ptype_manifest) with - | Ptype_abstract, None -> () - | _ -> - raise - (Error - ( sdecl.ptype_loc, - Invalid_attribute - "@notUndefined can only be used on abstract types" ))); + && sdecl.ptype_kind <> Ptype_abstract + then + raise + (Ast_untagged_variants.Error + (sdecl.ptype_loc, RuntimeAnnotationOnRepresentedType "notUndefined")); Ast_untagged_variants.check_runtime_annotation ~loc:sdecl.ptype_loc ~is_abstract_or_abbreviation:(sdecl.ptype_kind = Ptype_abstract) sdecl.ptype_attributes; @@ -1322,7 +1304,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), _), _ -> @@ -1602,8 +1584,7 @@ let transl_type_decl env rec_flag sdecl_list = in List.iter2 (fun sdecl (_, decl) -> - Variant_layout.check_manifest_annotation ~loc:sdecl.ptype_loc ~env:newenv - decl) + check_manifest_annotations ~loc:sdecl.ptype_loc ~env:newenv decl) sdecl_list decls; List.iter2 (check_constraints ~type_record_as_object newenv) sdecl_list decls; (* Name recursion *) @@ -2016,7 +1997,7 @@ let transl_with_constraint env id row_path orig_decl sdecl = let decl = {decl with type_shape = Variant_layout.declaration_shape ~env decl} in - Variant_layout.check_manifest_annotation ~loc:sdecl.ptype_loc ~env decl; + check_manifest_annotations ~loc:sdecl.ptype_loc ~env decl; let decl = name_recursion sdecl id decl in let type_variance = compute_variance_decl env true decl @@ -2150,7 +2131,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 4ad9213b739..4d2be412ed4 100644 --- a/compiler/ml/typeopt.ml +++ b/compiler/ml/typeopt.ml @@ -24,7 +24,7 @@ let scrape_ty env ty = | Tconstr (p, _, _) -> ( match Env.find_type p env with | {type_representation = Unboxed; _} -> ( - match Typedecl.get_unboxed_type_representation env ty with + match Ctype.get_unboxed_type_representation env ty with | None -> ty | Some ty2 -> ty2) | _ -> ty @@ -122,6 +122,28 @@ let rec cannot_contain_undefined ~visiting (typ : Types.type_expr) (env : Env.t) let type_cannot_contain_undefined typ env = cannot_contain_undefined ~visiting:[] typ env +type undefinedness = + | Cannot_be_undefined + | Unseen + | Stands_for_another + | Can_be_undefined + +(* Whether a type can hold [undefined], as far as the compiler sees. An + abstract type, also through an abbreviation, or a JavaScript object type + has a representation the compiler does not see; a functor parameter's or a + locally abstract type stands for any type. *) +let undefinedness env ty = + if type_cannot_contain_undefined ty env then Cannot_be_undefined + else + match (Ctype.expand_head_opt env ty).desc with + | Tconstr (path, _, _) -> ( + match Variant_layout.abstractness ~env path with + | Opaque -> Unseen + | Stands_for_another -> Stands_for_another + | Not_abstract -> Can_be_undefined) + | Tobject _ -> Unseen + | _ -> Can_be_undefined + let is_function_type env ty = match scrape env ty with | Tarrow (params, ret) -> Some ((List.hd params).typ, ret) diff --git a/compiler/ml/typeopt.mli b/compiler/ml/typeopt.mli index f51b0227f08..4bafce4bf71 100644 --- a/compiler/ml/typeopt.mli +++ b/compiler/ml/typeopt.mli @@ -22,3 +22,14 @@ val is_base_type : Env.t -> Types.type_expr -> Path.t -> bool val maybe_pointer_type : Env.t -> Types.type_expr -> Lambda.immediate_or_pointer val type_cannot_contain_undefined : Types.type_expr -> Env.t -> bool + +(** Whether a type can hold [undefined]: it cannot, the compiler does not see + its representation, it stands for another type (a functor parameter's or + a locally abstract type), or it can *) +type undefinedness = + | Cannot_be_undefined + | Unseen + | Stands_for_another + | Can_be_undefined + +val undefinedness : Env.t -> Types.type_expr -> undefinedness diff --git a/compiler/ml/variant_layout.ml b/compiler/ml/variant_layout.ml index 1dc17d28f80..7df407e6e58 100644 --- a/compiler/ml/variant_layout.ml +++ b/compiler/ml/variant_layout.ml @@ -49,8 +49,13 @@ let declaration_shape ~env (decl : Types.type_declaration) : value_shape = | Some _ | None -> [] in Recognized_as (InstanceType (Class {name; ancestors})) - | None -> - if has_not_undefined decl.type_attributes then Never_undefined else Unstated + | None -> ( + if not (has_not_undefined decl.type_attributes) then Unstated + else + (* Restating a kind the abbreviated type is recognized by keeps it *) + match Option.map (value_shape ~env) decl.type_manifest with + | Some (Recognized_as _ as shape) -> shape + | Some (Unstated | Never_undefined) | None -> Never_undefined) (* Resolves the shapes of a group of declarations, which can abbreviate each other. Each round resolves one more level of abbreviation within the diff --git a/tests/build_tests/not_undefined_attribute/demo.res b/tests/build_tests/not_undefined_attribute/demo.res index 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/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/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/tests/src/as_constructor_name_test.res b/tests/tests/src/as_constructor_name_test.res index 678c15d0ba7..c2fb3fb278e 100644 --- a/tests/tests/src/as_constructor_name_test.res +++ b/tests/tests/src/as_constructor_name_test.res @@ -7,7 +7,7 @@ open Test_utils type named = A | B type declared = | @as("A") A | B | C -let declaredA = (A: named :> declared) +let declaredA = ((A: named) :> declared) module Stated: { type t = A | B diff --git a/tests/tests/src/not_undefined_abbreviation_test.mjs b/tests/tests/src/not_undefined_abbreviation_test.mjs new file mode 100644 index 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") + }) +}) From d42a132eda6f1886863b19a99434cb3df4aedcc2 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 24 Oct 2026 12:02:35 +0000 Subject: [PATCH 07/19] Fold matches of constructors by their runtime literals Why: A coercion accepts constructors whose literals are spelled differently but are the same value, such as `@as(1.)` for `@as(1.0)`, while a match on a constant constructor was folded by comparing tags structurally, so the coerced constant missed its arm. Constant constructors and tagged blocks are now found by the runtime value of their literal, as the untagged dispatch already does. JS modified (folded match of a coerced constant): Example: type source = | @as(1.) One type target = | @as(1.0) One | Two | Three | Four let isOne = (x: target) => switch x { | One => true | _ => false } let r = isOne((One: source :> target)) Before (js): let r = false; After (js): let r = true; Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- compiler/ml/lambda.ml | 22 +++++++++++++----- tests/tests/src/as_constructor_name_test.mjs | 18 +++++++++++++-- tests/tests/src/as_constructor_name_test.res | 24 ++++++++++++++++++++ 3 files changed, 56 insertions(+), 8 deletions(-) diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index e857e7cee7a..adf463126a3 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -909,11 +909,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 @@ -941,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) diff --git a/tests/tests/src/as_constructor_name_test.mjs b/tests/tests/src/as_constructor_name_test.mjs index 6800be087ee..a1373920eda 100644 --- a/tests/tests/src/as_constructor_name_test.mjs +++ b/tests/tests/src/as_constructor_name_test.mjs @@ -7,9 +7,21 @@ let Stated = { a: "A" }; +function isOne(x) { + return x === 1.0; +} + +function isOneOf(x) { + return x.TAG === 1.0; +} + Mocha.describe("As_constructor_name_test", () => { - Mocha.test("coercion", () => Test_utils.eq("File \"as_constructor_name_test.res\", line 22, characters 7-14", "A", "A")); - Mocha.test("interface", () => Test_utils.eq("File \"as_constructor_name_test.res\", line 26, characters 7-14", "A", "A")); + Mocha.test("coercion", () => Test_utils.eq("File \"as_constructor_name_test.res\", line 41, characters 7-14", "A", "A")); + Mocha.test("folded matches of coerced constants", () => { + Test_utils.eq("File \"as_constructor_name_test.res\", line 45, characters 7-14", true, true); + Test_utils.eq("File \"as_constructor_name_test.res\", line 46, characters 7-14", true, true); + }); + Mocha.test("interface", () => Test_utils.eq("File \"as_constructor_name_test.res\", line 50, characters 7-14", "A", "A")); }); let declaredA = "A"; @@ -17,5 +29,7 @@ let declaredA = "A"; export { declaredA, Stated, + isOne, + isOneOf, } /* Not a pure module */ diff --git a/tests/tests/src/as_constructor_name_test.res b/tests/tests/src/as_constructor_name_test.res index c2fb3fb278e..0996fc9e753 100644 --- a/tests/tests/src/as_constructor_name_test.res +++ b/tests/tests/src/as_constructor_name_test.res @@ -17,11 +17,35 @@ module Stated: { let a = A } +// Literals are compared by runtime value, also when a match is folded +type sourceNumber = | @as(1.) One +type targetNumber = | @as(1.0) One | Two | Three | Four + +let isOne = (x: targetNumber) => + switch x { + | One => true + | _ => false + } + +type sourceBlock = | @as(1.) OneOf(int) +type targetBlock = | @as(1.0) OneOf(int) | TwoOf(int) + +let isOneOf = (x: targetBlock) => + switch x { + | OneOf(_) => true + | _ => false + } + describe(__MODULE__, () => { test("coercion", () => { eq(__LOC__, declaredA, A) }) + test("folded matches of coerced constants", () => { + eq(__LOC__, isOne((One: sourceNumber) :> targetNumber), true) + eq(__LOC__, isOneOf((OneOf(1): sourceBlock) :> targetBlock), true) + }) + test("interface", () => { eq(__LOC__, Stated.a, Stated.A) }) From f42bd93abe773b76488343a3214fb7b02cabc77f Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 24 Oct 2026 16:46:20 +0000 Subject: [PATCH 08/19] Fold matches of numeric constants by their runtime value Why: A constant constructor represented by an int is lowered to an int, and a match on it was folded by comparing with the int tags of the matched variant only. A coercion accepts `@as(1)` for `@as(1.)`, so the coerced constant missed its arm. The int is compared with every constant's literal by value. JS modified (folded match of a coerced int constant): Example: type source = | @as(1) One type target = | @as(1.) One | Two | Three | Four let isOne = (x: target) => switch x { | One => true | _ => false } let r = isOne((One: source) :> target) Before (js): let r = false; After (js): let r = true; Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- compiler/ml/lambda.ml | 5 +++-- tests/tests/src/as_constructor_name_test.mjs | 14 ++++++++++---- tests/tests/src/as_constructor_name_test.res | 10 ++++++++++ 3 files changed, 23 insertions(+), 6 deletions(-) diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index adf463126a3..942936dd4ca 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -928,8 +928,9 @@ let switch lam (lam_switch : lambda_switch) : t = Ext_list.find_opt lam_switch.sw_consts (fun (key, action) -> match key with | Switch_int ordinal when ordinal = i -> Some action - | Switch_constructor (Constant {literal = Variant_runtime.Int value}) - when value = i -> + | Switch_constructor (Constant {literal}) + when literal_denotes_same (Int i) literal -> + (* A constant represented as a number, compared by value *) Some action | Switch_int _ | Switch_constructor _ -> None) in diff --git a/tests/tests/src/as_constructor_name_test.mjs b/tests/tests/src/as_constructor_name_test.mjs index a1373920eda..74c585a1129 100644 --- a/tests/tests/src/as_constructor_name_test.mjs +++ b/tests/tests/src/as_constructor_name_test.mjs @@ -11,17 +11,22 @@ function isOne(x) { return x === 1.0; } +function isOneInt(x) { + return x === 1; +} + function isOneOf(x) { return x.TAG === 1.0; } Mocha.describe("As_constructor_name_test", () => { - Mocha.test("coercion", () => Test_utils.eq("File \"as_constructor_name_test.res\", line 41, characters 7-14", "A", "A")); + Mocha.test("coercion", () => Test_utils.eq("File \"as_constructor_name_test.res\", line 50, characters 7-14", "A", "A")); Mocha.test("folded matches of coerced constants", () => { - Test_utils.eq("File \"as_constructor_name_test.res\", line 45, characters 7-14", true, true); - Test_utils.eq("File \"as_constructor_name_test.res\", line 46, characters 7-14", true, true); + Test_utils.eq("File \"as_constructor_name_test.res\", line 54, characters 7-14", true, true); + Test_utils.eq("File \"as_constructor_name_test.res\", line 55, characters 7-14", true, true); + Test_utils.eq("File \"as_constructor_name_test.res\", line 56, characters 7-14", true, true); }); - Mocha.test("interface", () => Test_utils.eq("File \"as_constructor_name_test.res\", line 50, characters 7-14", "A", "A")); + Mocha.test("interface", () => Test_utils.eq("File \"as_constructor_name_test.res\", line 60, characters 7-14", "A", "A")); }); let declaredA = "A"; @@ -30,6 +35,7 @@ export { declaredA, Stated, isOne, + isOneInt, isOneOf, } /* Not a pure module */ diff --git a/tests/tests/src/as_constructor_name_test.res b/tests/tests/src/as_constructor_name_test.res index 0996fc9e753..ff506e13143 100644 --- a/tests/tests/src/as_constructor_name_test.res +++ b/tests/tests/src/as_constructor_name_test.res @@ -27,6 +27,15 @@ let isOne = (x: targetNumber) => | _ => false } +type sourceInt = | @as(1) OneInt +type targetFloat = | @as(1.) OneInt | TwoInt | ThreeInt | FourInt + +let isOneInt = (x: targetFloat) => + switch x { + | OneInt => true + | _ => false + } + type sourceBlock = | @as(1.) OneOf(int) type targetBlock = | @as(1.0) OneOf(int) | TwoOf(int) @@ -44,6 +53,7 @@ describe(__MODULE__, () => { test("folded matches of coerced constants", () => { eq(__LOC__, isOne((One: sourceNumber) :> targetNumber), true) eq(__LOC__, isOneOf((OneOf(1): sourceBlock) :> targetBlock), true) + eq(__LOC__, isOneInt((OneInt: sourceInt) :> targetFloat), true) }) test("interface", () => { From a2a824cb2607d4281aacb94a4bd32a8b8548eaba Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Mon, 19 Oct 2026 13:31:33 +0000 Subject: [PATCH 09/19] Warn about untagged payload patterns shadowed by literal cases A payload pattern whose values are all literal-case values can never match (warning 11/12), and a literal case covers the equal bool payload value in the exhaustiveness check. Fixes #8806. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01Kr4cjoUi2f5VpMvE6wT9bo Signed-off-by: Christoph Knittel --- .../untagged-literal-overlap-warnings.fix.md | 1 + compiler/ext/warnings.ml | 14 +- compiler/ext/warnings.mli | 4 +- compiler/ml/parmatch.ml | 237 +++++++++++++++++- ...untagged_bool_payload_overlap.res.expected | 12 + ...agged_literal_shadows_payload.res.expected | 65 +++++ ...literal_shadows_payload_kinds.res.expected | 38 +++ ...ed_literal_shadows_or_pattern.res.expected | 12 + ...rning_11_untagged_bool_payload_overlap.res | 16 ++ ...ng_11_untagged_literal_shadows_payload.res | 44 ++++ ...untagged_literal_shadows_payload_kinds.res | 26 ++ ...12_untagged_literal_shadows_or_pattern.res | 8 + tests/tests/src/unboxed_variant_fold_test.mjs | 145 ++++++----- tests/tests/src/unboxed_variant_fold_test.res | 12 +- 14 files changed, 553 insertions(+), 81 deletions(-) create mode 100644 changes/untagged-literal-overlap-warnings.fix.md create mode 100644 tests/build_tests/super_errors/expected/warning_11_untagged_bool_payload_overlap.res.expected create mode 100644 tests/build_tests/super_errors/expected/warning_11_untagged_literal_shadows_payload.res.expected create mode 100644 tests/build_tests/super_errors/expected/warning_11_untagged_literal_shadows_payload_kinds.res.expected create mode 100644 tests/build_tests/super_errors/expected/warning_12_untagged_literal_shadows_or_pattern.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/warning_11_untagged_bool_payload_overlap.res create mode 100644 tests/build_tests/super_errors/fixtures/warning_11_untagged_literal_shadows_payload.res create mode 100644 tests/build_tests/super_errors/fixtures/warning_11_untagged_literal_shadows_payload_kinds.res create mode 100644 tests/build_tests/super_errors/fixtures/warning_12_untagged_literal_shadows_or_pattern.res diff --git a/changes/untagged-literal-overlap-warnings.fix.md b/changes/untagged-literal-overlap-warnings.fix.md new file mode 100644 index 00000000000..96d2acf47cf --- /dev/null +++ b/changes/untagged-literal-overlap-warnings.fix.md @@ -0,0 +1 @@ +- Warn about untagged variant payload patterns that can never match because a literal case has the same value, like `S("a")` with `@as("a") A | S(string)`, and treat `@as(true) Yes | Ans(bool)` as fully covered by `Yes | Ans(false)`. diff --git a/compiler/ext/warnings.ml b/compiler/ext/warnings.ml index cef394251de..83e5b65426e 100644 --- a/compiler/ext/warnings.ml +++ b/compiler/ext/warnings.ml @@ -34,8 +34,8 @@ type t = | Partial_application (* 5 *) | Partial_match of string (* 8 *) | Non_closed_record_pattern of string (* 9 *) - | Unused_match (* 11 *) - | Unused_pat (* 12 *) + | Unused_match of string (* 11 *) + | Unused_pat of string (* 12 *) | Unused_argument (* 20 *) | Nonreturning_statement (* 21 *) | Preprocessor of string (* 22 *) @@ -88,8 +88,8 @@ let number = function | Partial_application -> 5 | Partial_match _ -> 8 | Non_closed_record_pattern _ -> 9 - | Unused_match -> 11 - | Unused_pat -> 12 + | Unused_match _ -> 11 + | Unused_pat _ -> 12 | Unused_argument -> 20 | Nonreturning_statement -> 21 | Preprocessor _ -> 22 @@ -297,8 +297,10 @@ let message = function | Non_closed_record_pattern s -> "the following labels are not bound in this record pattern: " ^ s ^ "\nEither bind these labels explicitly or add ', _' to the pattern." - | Unused_match -> "this match case is unused." - | Unused_pat -> "this sub-pattern is unused." + | Unused_match "" -> "this match case is unused." + | Unused_match reason -> "this match case is unused.\n " ^ reason + | Unused_pat "" -> "this sub-pattern is unused." + | Unused_pat reason -> "this sub-pattern is unused.\n " ^ reason | Unused_argument -> "this argument will not be used by the function." | Nonreturning_statement -> "This statement does not continue execution; following code is unreachable." diff --git a/compiler/ext/warnings.mli b/compiler/ext/warnings.mli index 2d43ceb7109..b5ce7f62bc1 100644 --- a/compiler/ext/warnings.mli +++ b/compiler/ext/warnings.mli @@ -27,8 +27,8 @@ type t = | Partial_application (* 5 *) | Partial_match of string (* 8 *) | Non_closed_record_pattern of string (* 9 *) - | Unused_match (* 11 *) - | Unused_pat (* 12 *) + | Unused_match of string (* 11 *) + | Unused_pat of string (* 12 *) | Unused_argument (* 20 *) | Nonreturning_statement (* 21 *) | Preprocessor of string (* 22 *) diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index 15557ec177b..eb2af9d2799 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -2260,6 +2260,147 @@ let do_check_fragile_param exhaust loc casel pss = let do_check_fragile_gadt = do_check_fragile_param exhaust_gadt +(*****************************************) +(* Payloads shadowed by untagged literals *) +(*****************************************) + +(* An untagged variant tests its literal cases before its payload cases, so in + [@as("a") A | S(string)] the value "a" is always matched as [A]. A payload + pattern can therefore never match a value that is also the runtime value of + a literal case, wherever it appears in the match: [S("a")] is dead. *) + +type shadowed_payload = { + payload_constructor: string; + value: Variant_runtime.literal_tag; + literal_constructor: string; +} + +type payload_liveness = + | Never_matches of shadowed_payload list + | Matches of (pattern * shadowed_payload list) list + (** The pattern can match, except for these dead or-pattern alternatives *) + +let is_type_path path ty = + match (Ctype.repr ty).desc with + | Tconstr (p, _, _) -> Path.same p path + | _ -> false + +(* The runtime value of the only value [p] matches, when it is a literal *) +let rec pattern_literal p : Variant_runtime.literal_tag option = + match p.pat_desc with + | Tpat_constant (Const_string s) -> Some (String s) + | Tpat_constant (Const_int i | Const_char i) -> Some (Int i) + | Tpat_constant (Const_float f) -> Some (Float f) + | Tpat_constant (Const_bigint _) -> + (* Bigints are never compared, see [Variant_runtime.same_literal_value] *) + None + | Tpat_alias (p, _, _) -> pattern_literal p + | Tpat_construct (_, {cstr_name; cstr_res}, []) + when is_type_path Predef.path_bool cstr_res -> + Some (Bool (cstr_name = "true")) + | Tpat_construct (_, {cstr_res}, _) + when List.exists + (fun path -> is_type_path path cstr_res) + [Predef.path_unit; Predef.path_list; Predef.path_option] -> + None + | Tpat_construct (_, {cstr_kind = Ordinary_constructor r}, args) -> ( + match (Variant_runtime.representation r, args) with + | Constant tag, [] -> Some tag.literal + | Block (Untagged _), [arg] -> + (* An untagged payload is represented by the payload itself *) + pattern_literal arg + | (Constant _ | Block _), _ -> None) + | Tpat_construct (_, {cstr_kind = Extension_constructor _}, _) + | Tpat_any | Tpat_var _ | Tpat_interval _ | Tpat_tuple _ | Tpat_variant _ + | Tpat_record _ | Tpat_dict _ | Tpat_array _ | Tpat_or _ -> + None + +(* The literal cases that take precedence over an untagged payload constructor, + as runtime values and constructor names *) +let shadowing_literal_cases cd = + match cd.cstr_kind with + | Ordinary_constructor r -> ( + match Variant_runtime.representation r with + | Block (Untagged _) -> + let layout = Variant_runtime.get_layout r.variant in + List.init (Variant_runtime.length layout) Fun.id + |> List.filter_map (fun position -> + match Variant_runtime.constructor_at layout position with + | Constant tag -> Some (tag.literal, tag.name) + | Block _ -> None) + | Constant _ | Block (Tagged _) -> []) + | Extension_constructor _ -> [] + +let or_liveness liveness p1 p2 = + match (liveness p1, liveness p2) with + | Never_matches s1, Never_matches s2 -> Never_matches (s1 @ s2) + | Matches d1, Never_matches s2 -> Matches (d1 @ [(p2, s2)]) + | Never_matches s1, Matches d2 -> Matches ((p1, s1) :: d2) + | Matches d1, Matches d2 -> Matches (d1 @ d2) + +let rec payload_liveness p = + match p.pat_desc with + | Tpat_or (p1, p2, _) -> or_liveness payload_liveness p1 p2 + | Tpat_construct (_, cd, [arg]) -> ( + match shadowing_literal_cases cd with + | [] -> subpatterns_liveness p + | literal_cases -> + shadowed_argument_liveness ~payload_constructor:cd.cstr_name + ~literal_cases arg) + | _ -> subpatterns_liveness p + +(* A pattern that is not an or-pattern matches nothing as soon as one of its + subpatterns matches nothing *) +and subpatterns_liveness p = + let result = ref (Matches []) in + Typedtree.iter_pattern_desc + (fun sub -> + match (!result, payload_liveness sub) with + | Never_matches _, _ -> () + | Matches _, (Never_matches _ as dead) -> result := dead + | Matches d1, Matches d2 -> result := Matches (d1 @ d2)) + p.pat_desc; + !result + +and shadowed_argument_liveness ~payload_constructor ~literal_cases arg = + match arg.pat_desc with + | Tpat_or (p1, p2, _) -> + or_liveness + (shadowed_argument_liveness ~payload_constructor ~literal_cases) + p1 p2 + | _ -> ( + let shadowing_case = + match pattern_literal arg with + | Some value -> + List.find_opt + (fun (literal, _) -> Variant_runtime.same_literal_value value literal) + literal_cases + | None -> None + in + match shadowing_case with + | Some (value, literal_constructor) -> + Never_matches [{payload_constructor; value; literal_constructor}] + | None -> payload_liveness arg) + +let literal_to_string : Variant_runtime.literal_tag -> string = function + | String s -> "\"" ^ s ^ "\"" + | Int i -> string_of_int i + | Float f -> f + | BigInt b -> b ^ "n" + | Bool b -> string_of_bool b + | Null -> "null" + | Undefined -> "undefined" + +let shadowed_payload_reason shadowed = + shadowed |> List.sort_uniq compare + |> List.map (fun {payload_constructor; value; literal_constructor} -> + Printf.sprintf + "%s is the runtime value of constructor %s, so it is always matched as \ + %s, never as %s." + (literal_to_string value) literal_constructor literal_constructor + payload_constructor) + |> String.concat "\n " + (********************************) (* Exported unused clause check *) (********************************) @@ -2268,11 +2409,40 @@ let lower_cases casel = let lower = Dict_pattern.lowering (List.map (fun c -> c.c_lhs) casel) in List.map (fun c -> {c with c_lhs = lower c.c_lhs}) casel +(* Report cases and or-pattern alternatives that can never match because of + [payload_liveness]. Returns the cases that match nothing, and whether a + sub-pattern has already been reported. *) +let check_shadowed_payloads casel = + let reported = ref [] in + let dead_cases = + List.filter + (fun {c_lhs = q} -> + match payload_liveness q with + | Never_matches shadowed -> + Location.prerr_warning q.pat_loc + (Warnings.Unused_match (shadowed_payload_reason shadowed)); + true + | Matches dead_alternatives -> + List.iter + (fun (p, shadowed) -> + reported := p.pat_loc :: !reported; + Location.prerr_warning p.pat_loc + (Warnings.Unused_pat (shadowed_payload_reason shadowed))) + dead_alternatives; + false) + casel + in + (dead_cases, fun p -> List.mem p.pat_loc !reported) + let check_unused pred casel = - if Warnings.is_active Warnings.Unused_match then + if Warnings.is_active (Warnings.Unused_match "") then let casel = lower_cases casel in + let dead_cases, already_reported = check_shadowed_payloads casel in let rec do_rec pref = function | [] -> () + | case :: rem when List.memq case dead_cases -> + (* A case that matches nothing cannot make later cases unused *) + do_rec pref rem | {c_lhs = q; c_guard} :: rem -> let qs = [q] in (try @@ -2323,13 +2493,16 @@ let check_unused pred casel = | _ -> r in match r with - | Unused -> Location.prerr_warning q.pat_loc Warnings.Unused_match + | Unused -> + Location.prerr_warning q.pat_loc (Warnings.Unused_match "") | Upartial ps -> ps |> List.filter (fun p -> - not (Variant_type_spread.is_pat_from_variant_spread_attr p)) + not + (Variant_type_spread.is_pat_from_variant_spread_attr p + || already_reported p)) |> List.iter (fun p -> - Location.prerr_warning p.pat_loc Warnings.Unused_pat) + Location.prerr_warning p.pat_loc (Warnings.Unused_pat "")) | Used -> () with Empty | Not_found | NoGuard -> assert false); @@ -2361,8 +2534,62 @@ let check_partial_param do_check_partial do_check_fragile loc casel = do_check_fragile loc casel pss; total +(* For the exhaustiveness check only: a literal case of an untagged variant + also covers the payload values equal to its runtime value. This matters for + a bool payload, whose values can all be covered, as in + [@as(true) Yes | Ans(bool)] where [Yes | Ans(false)] is exhaustive. Other + payload types have infinitely many values, so the overlap can't complete a + match and is left out. *) +let rec with_bool_payload_overlaps p = + match p.pat_desc with + | Tpat_construct (_, {cstr_kind = Ordinary_constructor r}, []) -> ( + match Variant_runtime.representation r with + | Constant tag -> ( + match tag.literal with + | Bool b -> ( + let is_bool_payload cd = + match cd.cstr_kind with + | Ordinary_constructor r -> ( + match Variant_runtime.representation r with + | Block (Untagged {block_type = BooleanType}) -> true + | Constant _ | Block _ -> false) + | Extension_constructor _ -> false + in + match + List.find_opt is_bool_payload + (get_variant_constructors p.pat_env p.pat_type) + with + | Some payload_cd -> + let bool_cd = + List.find + (fun cd -> cd.cstr_name = string_of_bool b) + (get_variant_constructors p.pat_env (Predef.type_bool ())) + in + let construct cd args ty = + make_pat + (Tpat_construct (mknoloc (Longident.Lident cd.cstr_name), cd, args)) + ty p.pat_env + in + orify p + (construct payload_cd + [construct bool_cd [] (Predef.type_bool ())] + p.pat_type) + | None -> p) + | String _ | Int _ | Float _ | BigInt _ | Null | Undefined -> p) + | Block _ -> p) + | _ -> + { + p with + pat_desc = + Typedtree.map_pattern_desc with_bool_payload_overlaps p.pat_desc; + } + let check_partial_gadt ?partial_match_warning_hint pred loc casel = - let casel = lower_cases casel in + let casel = + List.map + (fun c -> {c with c_lhs = with_bool_payload_overlaps c.c_lhs}) + (lower_cases casel) + in check_partial_param (do_check_partial_gadt ?partial_match_warning_hint pred) do_check_fragile_gadt loc casel diff --git a/tests/build_tests/super_errors/expected/warning_11_untagged_bool_payload_overlap.res.expected b/tests/build_tests/super_errors/expected/warning_11_untagged_bool_payload_overlap.res.expected new file mode 100644 index 00000000000..ba54d0b7611 --- /dev/null +++ b/tests/build_tests/super_errors/expected/warning_11_untagged_bool_payload_overlap.res.expected @@ -0,0 +1,12 @@ + + Warning number 11 + /.../fixtures/warning_11_untagged_bool_payload_overlap.res:14:5-13 + + 12 ┆ switch x { + 13 ┆ | Yes => 1 + 14 ┆ | Ans(true) => 3 + 15 ┆ | Ans(false) => 2 + 16 ┆ } + + this match case is unused. + true is the runtime value of constructor Yes, so it is always matched as Yes, never as Ans. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/warning_11_untagged_literal_shadows_payload.res.expected b/tests/build_tests/super_errors/expected/warning_11_untagged_literal_shadows_payload.res.expected new file mode 100644 index 00000000000..a4157f9042f --- /dev/null +++ b/tests/build_tests/super_errors/expected/warning_11_untagged_literal_shadows_payload.res.expected @@ -0,0 +1,65 @@ + + Warning number 11 + /.../fixtures/warning_11_untagged_literal_shadows_payload.res:7:5-10 + + 5 ┆ switch x { + 6 ┆ | A => 1 + 7 ┆ | S("a") => 2 + 8 ┆ | S(_) => 3 + 9 ┆ } + + this match case is unused. + "a" is the runtime value of constructor A, so it is always matched as A, never as S. + + + Warning number 11 + /.../fixtures/warning_11_untagged_literal_shadows_payload.res:13:5-10 + + 11 │ let beforeLiteral = x => + 12 │ switch x { + 13 │ | S("a") => 2 + 14 │ | A => 1 + 15 │ | S(_) => 3 + + this match case is unused. + "a" is the runtime value of constructor A, so it is always matched as A, never as S. + + + Warning number 11 + /.../fixtures/warning_11_untagged_literal_shadows_payload.res:20:5-10 + + 18 │ let withoutLiteralCase = x => + 19 │ switch x { + 20 │ | S("a") => 2 + 21 │ | S(_) | A => 3 + 22 │ } + + this match case is unused. + "a" is the runtime value of constructor A, so it is always matched as A, never as S. + + + Warning number 11 + /.../fixtures/warning_11_untagged_literal_shadows_payload.res:26:5-15 + + 24 │ let nested = x => + 25 │ switch x { + 26 │ | (S("a"), _) => 1 + 27 │ | (S(_) | A, _) => 2 + 28 │ } + + this match case is unused. + "a" is the runtime value of constructor A, so it is always matched as A, never as S. + + + Warning number 11 + /.../fixtures/warning_11_untagged_literal_shadows_payload.res:42:5-21 + + 40 │ let allAlternatives = x => + 41 │ switch x { + 42 │ | US("a") | US("b") => 1 + 43 │ | US(_) | UA | UB => 2 + 44 │ } + + this match case is unused. + "a" is the runtime value of constructor UA, so it is always matched as UA, never as US. + "b" is the runtime value of constructor UB, so it is always matched as UB, never as US. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/warning_11_untagged_literal_shadows_payload_kinds.res.expected b/tests/build_tests/super_errors/expected/warning_11_untagged_literal_shadows_payload_kinds.res.expected new file mode 100644 index 00000000000..8d7b6b7fbc0 --- /dev/null +++ b/tests/build_tests/super_errors/expected/warning_11_untagged_literal_shadows_payload_kinds.res.expected @@ -0,0 +1,38 @@ + + Warning number 11 + /.../fixtures/warning_11_untagged_literal_shadows_payload_kinds.res:7:5-20 + + 5 │ let byName = x => + 6 │ switch x { + 7 │ | Color("Primary") => 1 + 8 │ | Color(_) | Primary => 2 + 9 │ } + + this match case is unused. + "Primary" is the runtime value of constructor Primary, so it is always matched as Primary, never as Color. + + + Warning number 11 + /.../fixtures/warning_11_untagged_literal_shadows_payload_kinds.res:15:5-10 + + 13 │ let intAndFloat = x => + 14 │ switch x { + 15 │ | F(1.0) => 1 + 16 │ | F(_) | One => 2 + 17 │ } + + this match case is unused. + 1 is the runtime value of constructor One, so it is always matched as One, never as F. + + + Warning number 11 + /.../fixtures/warning_11_untagged_literal_shadows_payload_kinds.res:24:5-8 + + 22 │ let nestedConstant = x => + 23 │ switch x { + 24 │ | W(P) => 1 + 25 │ | W(Q(_)) | X => 2 + 26 │ } + + this match case is unused. + "x" is the runtime value of constructor X, so it is always matched as X, never as W. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/warning_12_untagged_literal_shadows_or_pattern.res.expected b/tests/build_tests/super_errors/expected/warning_12_untagged_literal_shadows_or_pattern.res.expected new file mode 100644 index 00000000000..8ff24dce374 --- /dev/null +++ b/tests/build_tests/super_errors/expected/warning_12_untagged_literal_shadows_or_pattern.res.expected @@ -0,0 +1,12 @@ + + Warning number 12 + /.../fixtures/warning_12_untagged_literal_shadows_or_pattern.res:6:7-9 + + 4 │ let f = x => + 5 │ switch x { + 6 │ | S("a" | "b") => 2 + 7 │ | S(_) | A => 3 + 8 │ } + + this sub-pattern is unused. + "a" is the runtime value of constructor A, so it is always matched as A, never as S. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/warning_11_untagged_bool_payload_overlap.res b/tests/build_tests/super_errors/fixtures/warning_11_untagged_bool_payload_overlap.res new file mode 100644 index 00000000000..7cade40e6ac --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/warning_11_untagged_bool_payload_overlap.res @@ -0,0 +1,16 @@ +// true is always matched as Yes, so Ans(true) can never match, and a match +// covering Yes and Ans(false) is exhaustive (no warning for `exhaustive`). +@unboxed type b = | @as(true) Yes | Ans(bool) + +let exhaustive = x => + switch x { + | Yes => 1 + | Ans(false) => 2 + } + +let deadArm = x => + switch x { + | Yes => 1 + | Ans(true) => 3 + | Ans(false) => 2 + } diff --git a/tests/build_tests/super_errors/fixtures/warning_11_untagged_literal_shadows_payload.res b/tests/build_tests/super_errors/fixtures/warning_11_untagged_literal_shadows_payload.res new file mode 100644 index 00000000000..435ca4cc117 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/warning_11_untagged_literal_shadows_payload.res @@ -0,0 +1,44 @@ +// "a" is always matched as A, so S("a") can never match, wherever it appears. +@unboxed type t = | @as("a") A | S(string) + +let afterLiteral = x => + switch x { + | A => 1 + | S("a") => 2 + | S(_) => 3 + } + +let beforeLiteral = x => + switch x { + | S("a") => 2 + | A => 1 + | S(_) => 3 + } + +let withoutLiteralCase = x => + switch x { + | S("a") => 2 + | S(_) | A => 3 + } + +let nested = x => + switch x { + | (S("a"), _) => 1 + | (S(_) | A, _) => 2 + } + +// Payloads that are not literal values still match. +let fine = x => + switch x { + | S("b") => 1 + | S(s) => String.length(s) + | A => 0 + } + +// Every alternative can never match. +@unboxed type u = | @as("a") UA | @as("b") UB | US(string) +let allAlternatives = x => + switch x { + | US("a") | US("b") => 1 + | US(_) | UA | UB => 2 + } diff --git a/tests/build_tests/super_errors/fixtures/warning_11_untagged_literal_shadows_payload_kinds.res b/tests/build_tests/super_errors/fixtures/warning_11_untagged_literal_shadows_payload_kinds.res new file mode 100644 index 00000000000..0f1aaa929f6 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/warning_11_untagged_literal_shadows_payload_kinds.res @@ -0,0 +1,26 @@ +// Literal values are compared as runtime values. + +// Without @as, a constructor is represented by its name. +@unboxed type color = Primary | Color(string) +let byName = x => + switch x { + | Color("Primary") => 1 + | Color(_) | Primary => 2 + } + +// @as(1) and 1.0 are the same JavaScript number. +@unboxed type num = | @as(1) One | F(float) +let intAndFloat = x => + switch x { + | F(1.0) => 1 + | F(_) | One => 2 + } + +// A nested untagged constant has the value of its @as. +@unboxed type inner = | @as("x") P | Q(int) +@unboxed type outer = | @as("x") X | W(inner) +let nestedConstant = x => + switch x { + | W(P) => 1 + | W(Q(_)) | X => 2 + } diff --git a/tests/build_tests/super_errors/fixtures/warning_12_untagged_literal_shadows_or_pattern.res b/tests/build_tests/super_errors/fixtures/warning_12_untagged_literal_shadows_or_pattern.res new file mode 100644 index 00000000000..43271e479c3 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/warning_12_untagged_literal_shadows_or_pattern.res @@ -0,0 +1,8 @@ +// Only the "a" alternative can never match: "a" is always matched as A. +@unboxed type t = | @as("a") A | S(string) + +let f = x => + switch x { + | S("a" | "b") => 2 + | S(_) | A => 3 + } diff --git a/tests/tests/src/unboxed_variant_fold_test.mjs b/tests/tests/src/unboxed_variant_fold_test.mjs index 686732a8afe..3f6e07e1bd0 100644 --- a/tests/tests/src/unboxed_variant_fold_test.mjs +++ b/tests/tests/src/unboxed_variant_fold_test.mjs @@ -55,6 +55,14 @@ function answerName(v) { } } +function answerName2(v) { + if (v === true) { + return "yes"; + } else { + return "answer false"; + } +} + function mixedName(v) { if (v === false) { return "off"; @@ -169,94 +177,96 @@ function makeRecord(value) { Mocha.describe("Unboxed_variant_fold_test", () => { Mocha.test("constructors preserve dynamic payloads and effects", () => { - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 174, characters 7-14", colorName(makeColor("primary")), "not Color"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 175, characters 7-14", colorName(makeColor("blue")), "blue"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 176, characters 7-14", recName(makeRecord(1)), "rec"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 182, characters 7-14", colorName(makeColor("primary")), "not Color"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 183, characters 7-14", colorName(makeColor("blue")), "blue"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 184, characters 7-14", recName(makeRecord(1)), "rec"); let calls = 0; calls = calls + 1 | 0; - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 182, characters 7-14", colorName("primary"), "not Color"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 183, characters 7-14", calls, 1); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 190, characters 7-14", colorName("primary"), "not Color"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 191, characters 7-14", calls, 1); }); Mocha.test("folding agrees with runtime dispatch", () => { - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 186, characters 7-14", "not Color", colorName(id("primary"))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 187, characters 7-14", "not Color", colorName(id("secondary"))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 188, characters 7-14", "blue", colorName(id("blue"))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 189, characters 7-14", "not Color", colorName(id("primary"))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 190, characters 7-14", "one", numberName(id(1))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 191, characters 7-14", "number", numberName(id(2))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 192, characters 7-14", "one", numberName(id(1))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 193, characters 7-14", "int", pureName(id(1))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 194, characters 7-14", "string", pureName(id("x"))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 195, characters 7-14", "obj", optName(id({ + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 194, characters 7-14", "not Color", colorName(id("primary"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 195, characters 7-14", "not Color", colorName(id("secondary"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 196, characters 7-14", "blue", colorName(id("blue"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 197, characters 7-14", "not Color", colorName(id("primary"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 198, characters 7-14", "one", numberName(id(1))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 199, characters 7-14", "number", numberName(id(2))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 200, characters 7-14", "one", numberName(id(1))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 201, characters 7-14", "int", pureName(id(1))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 202, characters 7-14", "string", pureName(id("x"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 203, characters 7-14", "obj", optName(id({ x: 1 }))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 196, characters 7-14", "null", optName(id(null))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 197, characters 7-14", "undef", optName(id(undefined))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 198, characters 7-14", "str", flagName(id("true"))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 199, characters 7-14", "yes", flagName(id(true))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 200, characters 7-14", "yes", answerName(id(true))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 201, characters 7-14", "answer false", answerName(id(false))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 202, characters 7-14", "yes", answerName(id(true))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 203, characters 7-14", "toggle true", mixedName(id(true))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 204, characters 7-14", "off", mixedName(id(false))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 205, characters 7-14", "off", mixedName(id(false))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 206, characters 7-14", "unset", mixedName(id(null))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 207, characters 7-14", "false", mixedName(id("false"))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 208, characters 7-14", "one", numName(id(1.0))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 209, characters 7-14", "float", numName(id(2.5))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 210, characters 7-14", "one", numName(id(1))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 211, characters 7-14", "rec", recName(id({ + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 204, characters 7-14", "null", optName(id(null))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 205, characters 7-14", "undef", optName(id(undefined))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 206, characters 7-14", "str", flagName(id("true"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 207, characters 7-14", "yes", flagName(id(true))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 208, characters 7-14", "yes", answerName(id(true))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 209, characters 7-14", "answer false", answerName(id(false))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 210, characters 7-14", "yes", answerName(id(true))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 211, characters 7-14", "toggle true", mixedName(id(true))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 212, characters 7-14", "off", mixedName(id(false))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 213, characters 7-14", "off", mixedName(id(false))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 214, characters 7-14", "unset", mixedName(id(null))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 215, characters 7-14", "false", mixedName(id("false"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 216, characters 7-14", "one", numName(id(1.0))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 217, characters 7-14", "float", numName(id(2.5))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 218, characters 7-14", "one", numName(id(1))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 219, characters 7-14", "rec", recName(id({ y: 1 }))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 212, characters 7-14", "empty", recName(id("empty"))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 213, characters 7-14", "lit", pick(id("a"))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 214, characters 7-14", "z", pick(id("z"))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 215, characters 7-14", "lit", pick(id("a"))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 216, characters 7-14", "w", outerName(id("primary"))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 217, characters 7-14", "x", outerName(id("x"))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 218, characters 7-14", "x", outerName(id("x"))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 219, characters 7-14", "primary", boxedName(id({ + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 220, characters 7-14", "empty", recName(id("empty"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 221, characters 7-14", "lit", pick(id("a"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 222, characters 7-14", "z", pick(id("z"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 223, characters 7-14", "lit", pick(id("a"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 224, characters 7-14", "w", outerName(id("primary"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 225, characters 7-14", "x", outerName(id("x"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 226, characters 7-14", "x", outerName(id("x"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 227, characters 7-14", "primary", boxedName(id({ TAG: "BoxedColor", _0: "primary" }))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 220, characters 7-14", "not Color", boxedName(id("primary"))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 221, characters 7-14", "tuple", objectName(id([ + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 228, characters 7-14", "not Color", boxedName(id("primary"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 229, characters 7-14", "tuple", objectName(id([ 1, 2 ]))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 222, characters 7-14", "record", objectName(id({ + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 230, characters 7-14", "record", objectName(id({ x: 1 }))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 223, characters 7-14", "zero", listName(id(/* [] */0))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 224, characters 7-14", "list", listName(id({hd: 1, tl: /* [] */0}))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 225, characters 7-14", bigintName(10n), bigintName(id(10n))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 226, characters 7-14", "one", wideName(id(1))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 231, characters 7-14", "zero", listName(id(/* [] */0))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 232, characters 7-14", "list", listName(id({hd: 1, tl: /* [] */0}))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 233, characters 7-14", bigintName(10n), bigintName(id(10n))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 234, characters 7-14", "one", wideName(id(1))); }); Mocha.test("the folded answers themselves are correct", () => { - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 230, characters 7-14", "not Color", "not Color"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 231, characters 7-14", "blue", "blue"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 232, characters 7-14", "one", "one"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 233, characters 7-14", "number", "number"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 234, characters 7-14", "int", "int"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 235, characters 7-14", "yes", "yes"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 236, characters 7-14", "answer false", "answer false"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 237, characters 7-14", "off", "off"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 238, characters 7-14", "toggle true", "toggle true"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 239, characters 7-14", "false", "false"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 238, characters 7-14", "not Color", "not Color"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 239, characters 7-14", "blue", "blue"); Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 240, characters 7-14", "one", "one"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 241, characters 7-14", "lit", "lit"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 242, characters 7-14", "x", "x"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 243, characters 7-14", "primary", "primary"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 244, characters 7-14", "tuple", "tuple"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 245, characters 7-14", "zero", "zero"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 246, characters 7-14", bigintName(10n), "one"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 247, characters 7-14", "one", "one"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 248, characters 7-14", numberOrBigintName(1n), "bigint"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 241, characters 7-14", "number", "number"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 242, characters 7-14", "int", "int"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 243, characters 7-14", "yes", "yes"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 244, characters 7-14", "answer false", "answer false"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 245, characters 7-14", answerName2(id(true)), "yes"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 246, characters 7-14", answerName2(id(false)), "answer false"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 247, characters 7-14", "off", "off"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 248, characters 7-14", "toggle true", "toggle true"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 249, characters 7-14", "false", "false"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 250, characters 7-14", "one", "one"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 251, characters 7-14", "lit", "lit"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 252, characters 7-14", "x", "x"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 253, characters 7-14", "primary", "primary"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 254, characters 7-14", "tuple", "tuple"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 255, characters 7-14", "zero", "zero"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 256, characters 7-14", bigintName(10n), "one"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 257, characters 7-14", "one", "one"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 258, characters 7-14", numberOrBigintName(1n), "bigint"); }); Mocha.test("a number and a bigint literal with the same digits", () => { - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 252, characters 7-14", numberOrBigintName(id(1)), "number"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 253, characters 7-14", numberOrBigintName(id(1n)), "bigint"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 254, characters 7-14", numberOrBigintName(id("x")), "x"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 262, characters 7-14", numberOrBigintName(id(1)), "number"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 263, characters 7-14", numberOrBigintName(id(1n)), "bigint"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 264, characters 7-14", numberOrBigintName(id("x")), "x"); }); }); @@ -267,6 +277,7 @@ export { optName, flagName, answerName, + answerName2, mixedName, numName, recName, diff --git a/tests/tests/src/unboxed_variant_fold_test.res b/tests/tests/src/unboxed_variant_fold_test.res index bcb77655686..d2b1440502c 100644 --- a/tests/tests/src/unboxed_variant_fold_test.res +++ b/tests/tests/src/unboxed_variant_fold_test.res @@ -57,14 +57,22 @@ let flagName = v => | Str(_) => "str" } -// A boolean payload only receives the boolean that is not a literal case. +// A boolean payload only receives the boolean that is not a literal case. The +// first arm can never match (warning 11); folding must not select it either. @unboxed type answer = | @as(true) Yes2 | Answer(bool) +@warning("-11") let answerName = v => switch v { | Answer(true) => "answer true" | Yes2 => "yes" | Answer(false) => "answer false" } +// Yes2 also covers Answer(true), so this match is exhaustive. +let answerName2 = v => + switch v { + | Yes2 => "yes" + | Answer(false) => "answer false" + } @unboxed type mixed = @@ -234,6 +242,8 @@ describe(__MODULE__, () => { eq(__LOC__, pureName(I(1)), "int") eq(__LOC__, answerName(Answer(true)), "yes") eq(__LOC__, answerName(Answer(false)), "answer false") + eq(__LOC__, answerName2(id(Answer(true))), "yes") + eq(__LOC__, answerName2(id(Answer(false))), "answer false") eq(__LOC__, mixedName(Toggle(false)), "off") eq(__LOC__, mixedName(Toggle(true)), "toggle true") eq(__LOC__, mixedName(Label("false")), "false") From fc353d3d1e8aad5b441de85b349c5951d83ef6dd Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Tue, 20 Oct 2026 11:53:17 +0000 Subject: [PATCH 10/19] Report shadowed payload alternatives when only warning 12 is on The check for untagged payload patterns shadowed by literal cases ran only when warning 11 was active, so with `-w -11+12` or `@warning("-11")` a dead or-pattern alternative got no warning 12. It now runs when either warning is active; the usefulness analysis is still gated on warning 11. Example (rescript): @unboxed type t = | @as("a") A | S(string) @warning("-11") let g = x => switch x { | S("a") => 1 | S("a" | "c") => 2 | S(_) | A => 3 } Diagnostic (text): Before: no warnings After: Warning 12 on the "a" in S("a" | "c"); the dead S("a") case stays silent because warning 11 is off. Area: typechecker tests Output: unchanged Formats: none PPX: unchanged Editor: unchanged Tests: ~tests/build_tests/super_errors/fixtures/warning_12_untagged_literal_shadows_or_pattern.res Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01Kr4cjoUi2f5VpMvE6wT9bo Signed-off-by: Christoph Knittel --- compiler/ml/parmatch.ml | 7 +++++-- ...untagged_literal_shadows_or_pattern.res.expected | 13 +++++++++++++ ...rning_12_untagged_literal_shadows_or_pattern.res | 10 ++++++++++ 3 files changed, 28 insertions(+), 2 deletions(-) diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index eb2af9d2799..beb35fce470 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -2435,7 +2435,10 @@ let check_shadowed_payloads casel = (dead_cases, fun p -> List.mem p.pat_loc !reported) let check_unused pred casel = - if Warnings.is_active (Warnings.Unused_match "") then + let unused_match = Warnings.is_active (Warnings.Unused_match "") in + (* Shadowed payloads are reported as warning 11 or 12, so they are checked + when either is active; the usefulness analysis below only when 11 is. *) + if unused_match || Warnings.is_active (Warnings.Unused_pat "") then let casel = lower_cases casel in let dead_cases, already_reported = check_shadowed_payloads casel in let rec do_rec pref = function @@ -2509,7 +2512,7 @@ let check_unused pred casel = if c_guard <> None then do_rec pref rem else do_rec ([q] :: pref) rem in - do_rec [] casel + if unused_match then do_rec [] casel (*********************************) (* Exported irrefutability tests *) diff --git a/tests/build_tests/super_errors/expected/warning_12_untagged_literal_shadows_or_pattern.res.expected b/tests/build_tests/super_errors/expected/warning_12_untagged_literal_shadows_or_pattern.res.expected index 8ff24dce374..6d716a4d874 100644 --- a/tests/build_tests/super_errors/expected/warning_12_untagged_literal_shadows_or_pattern.res.expected +++ b/tests/build_tests/super_errors/expected/warning_12_untagged_literal_shadows_or_pattern.res.expected @@ -8,5 +8,18 @@ 7 │ | S(_) | A => 3 8 │ } + this sub-pattern is unused. + "a" is the runtime value of constructor A, so it is always matched as A, never as S. + + + Warning number 12 + /.../fixtures/warning_12_untagged_literal_shadows_or_pattern.res:16:7-9 + + 14 ┆ switch x { + 15 ┆ | S("a") => 1 + 16 ┆ | S("a" | "c") => 2 + 17 ┆ | S(_) | A => 3 + 18 ┆ } + this sub-pattern is unused. "a" is the runtime value of constructor A, so it is always matched as A, never as S. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/warning_12_untagged_literal_shadows_or_pattern.res b/tests/build_tests/super_errors/fixtures/warning_12_untagged_literal_shadows_or_pattern.res index 43271e479c3..364db46971c 100644 --- a/tests/build_tests/super_errors/fixtures/warning_12_untagged_literal_shadows_or_pattern.res +++ b/tests/build_tests/super_errors/fixtures/warning_12_untagged_literal_shadows_or_pattern.res @@ -6,3 +6,13 @@ let f = x => | S("a" | "b") => 2 | S(_) | A => 3 } + +// With warning 11 off, the dead alternative still gets warning 12, while the +// dead case gets nothing. +@warning("-11") +let g = x => + switch x { + | S("a") => 1 + | S("a" | "c") => 2 + | S(_) | A => 3 + } From c49c11ed1288a9e20998fa23416d8f3567ef3952 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 24 Oct 2026 11:39:57 +0000 Subject: [PATCH 11/19] Describe the shadowed payload warnings in the spec Rule 7 says which payload patterns a literal case shadows, which warnings report them, and how a literal case counts in the exhaustiveness check. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- compiler/ml/UntaggedVariants.md | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/compiler/ml/UntaggedVariants.md b/compiler/ml/UntaggedVariants.md index 9714db16b71..91d4f5c5f0d 100644 --- a/compiler/ml/UntaggedVariants.md +++ b/compiler/ml/UntaggedVariants.md @@ -285,10 +285,22 @@ otherwise it reaches the default through the payload dispatch, which then checks its last arm. A `null` literal that only the object check would accept adds `x !== null` to that check instead (rule 9). -- Implementation: `lam_compile.ml:compile_switch`. +A payload pattern whose every value is a literal case's can therefore never +match, and is reported: warning 11 for an arm, such as `S("a")` beside +`@as("a") A`, and warning 12 for an alternative of an or-pattern, both with +"\"a\" is the runtime value of constructor A, so it is always matched as A, +never as S". Values are compared as `===` compares them (rule 6). For the +exhaustiveness check a literal case covers the payload values equal to it, so +`Yes | Ans(false)` is a complete match of `@as(true) Yes | Ans(bool)`. + +- Implementation: `lam_compile.ml:compile_switch`; + `parmatch.ml` (shadowed payload patterns, exhaustiveness). - Tests: `spec_test` rule 7; `tests/tests/src/untagged_variants_heuristic.res` - (literals that skip the `switch`). -- Shaped by #6125, #7128, #7135. + (literals that skip the `switch`); `unboxed_variant_fold_test.res` + (`answerName2`); fixtures `warning_11_untagged_literal_shadows_payload.res`, + `warning_11_untagged_literal_shadows_payload_kinds.res`, + `warning_12_untagged_literal_shadows_or_pattern.res`. +- Shaped by #6125, #7128, #7135, #8806. ### 8. Payload cases From 59739f7a26082f86fa7f2aab4c7fadb1b29df298 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 24 Oct 2026 13:27:55 +0000 Subject: [PATCH 12/19] Say in rule 6 that variants with some @unboxed constructors are checked #9021 checks a variant with some `@unboxed` constructors like an untagged one: tagged blocks count as one object case, and an untagged case's `@as` is not a tag. Rule 6 now says so and names its tests. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- compiler/ml/UntaggedVariants.md | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/compiler/ml/UntaggedVariants.md b/compiler/ml/UntaggedVariants.md index 91d4f5c5f0d..89da10cebc2 100644 --- a/compiler/ml/UntaggedVariants.md +++ b/compiler/ml/UntaggedVariants.md @@ -219,8 +219,14 @@ written (Known bugs). ### 6. Well-formedness -The type checker rejects an untagged variant, with -"This untagged variant definition is invalid: ..." and the reason below, when: +The type checker rejects a variant with an untagged case, with +"This untagged variant definition is invalid: ..." and the reason below, when +the condition holds. This includes a variant where only some constructors are +`@unboxed` (rule 1). There, the tagged blocks together count as one object +case, and the `@as` of an untagged case is not a tag, so it does not clash +with a tagged case's (`untagged_mixed_test.res`; fixtures +`untagged_mixed_two_numbers.res`, `untagged_mixed_unknown_payload.res`, +`untagged_mixed_object_and_tagged.res`; #9020). | Condition | Reason | Fixture | | --- | --- | --- | From bb944d85afc2f3a2f40a8fdb4e4e464b2dcb4e98 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 24 Oct 2026 16:18:21 +0000 Subject: [PATCH 13/19] Require a private abbreviation for every subclass Why: A public abbreviation could declare a subclass when its arguments were not all type variables, meant for phantom type hierarchies. The test was syntactic, so `@instanceOf("Dog") type dog = animal` passed, and every `animal` was then a dog without a coercion. A subclass is always a private abbreviation, phantom hierarchies included; upcasts use `:>`. Diagnostic added (public subclass of an instantiated class): Example: @instanceOf("Animal") type animal<'a> @instanceOf("Dog") type dog = animal Before (diagnostic): none After (diagnostic): A subclass must be a private abbreviation: write `= private ...` so that instances of Animal cannot be used as instances of Dog without a coercion. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- changes/untagged-private-subclasses.polish.md | 1 + compiler/ml/UntaggedVariants.md | 16 +++++++--------- compiler/ml/variant_layout.ml | 13 +++---------- ...ance_of_public_subclass_instance.res.expected | 9 +++++++++ .../instance_of_public_subclass_instance.res | 2 ++ .../src/untagged_runtime_annotations_test.res | 6 +++--- 6 files changed, 25 insertions(+), 22 deletions(-) create mode 100644 changes/untagged-private-subclasses.polish.md create mode 100644 tests/build_tests/super_errors/expected/instance_of_public_subclass_instance.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/instance_of_public_subclass_instance.res diff --git a/changes/untagged-private-subclasses.polish.md b/changes/untagged-private-subclasses.polish.md new file mode 100644 index 00000000000..4b77b0115c6 --- /dev/null +++ b/changes/untagged-private-subclasses.polish.md @@ -0,0 +1 @@ +- Require `= private` for every subclass declared with `@instanceOf`, also in phantom type hierarchies, and fold `null` into an untagged variant's object case as it is matched at run time. diff --git a/compiler/ml/UntaggedVariants.md b/compiler/ml/UntaggedVariants.md index 89da10cebc2..0af5468e1c3 100644 --- a/compiler/ml/UntaggedVariants.md +++ b/compiler/ml/UntaggedVariants.md @@ -151,19 +151,18 @@ int` does. The type of a functor parameter, of a recursive module being defined, and a locally abstract type `(type a)` are abstract only where they are declared: they stand for another type, so they cannot be refined. Only a private abbreviation can declare a subclass of the -class annotated there, or of a `@typeOf("object")` type, or a public one that -is a strict instance of the superclass type after expansion, as in the -phantom type hierarchy -`@instanceOf("Element") type elementLike<'a> = nodeLike<_element<'a>>`. A -public `type dog = animal` would make every animal a dog without a coercion, -and so would `type dog = phantom` with `type phantom<'a> = animal`. +class annotated there, or of a `@typeOf("object")` type, also in a phantom +type hierarchy (`type dogLike<'a> = private animalLike<_dog<'a>>`). A public +`type dog = animal` would make every animal a dog without a coercion, and so +would `type dog = animal` or `type dog = phantom` with +`type phantom<'a> = animal`. | Declaration | Error | Fixture | | --- | --- | --- | | `@typeOf("string") type t = option`, `type t<'a> = 'a`, an abbreviation of `unit`, `list<_>`, a record or a variant | @typeOf on a type abbreviation must describe an abstract type, ... | `runtime_annotation_on_option.res`, `runtime_annotation_on_type_variable.res` | | `@typeOf("number") type t = sym` with `@typeOf("symbol") type sym`, or `@typeOf("string") type t = int` | This annotation, @typeOf("number"), contradicts the abbreviated type, whose values are recognized by @typeOf("symbol"). | `runtime_annotation_contradicts_manifest.res`, `runtime_annotation_contradicts_builtin.res` | | `@instanceOf("Date") type date = X.t` in a functor of `X`, or over `(type a)` | @instanceOf cannot describe the type of a functor parameter, ... | `instance_of_functor_parameter.res`, `type_of_locally_abstract_type.res` | -| `@instanceOf("Dog") type dog = animal`, or `= phantom` with `type phantom<'a> = animal` | A subclass must be a private abbreviation ... | `instance_of_public_subclass.res`, `instance_of_public_subclass_through_alias.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` | @@ -574,8 +573,7 @@ had to answer, and the answers of rule 5: 1. **Unchecked claims.** An annotation is trusted, as the type of an external is, but checked against the type it abbreviates (rule 5). 2. **Subclasses.** A class's superclasses are the classes annotated further - down its chain of private abbreviations, or of strict instances in a - phantom type hierarchy. A superclass case excludes its subclass cases in + 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). diff --git a/compiler/ml/variant_layout.ml b/compiler/ml/variant_layout.ml index 7df407e6e58..40eb5e26ce7 100644 --- a/compiler/ml/variant_layout.ml +++ b/compiler/ml/variant_layout.ml @@ -145,15 +145,8 @@ let check_manifest_annotation ~loc ~env (decl : Types.type_declaration) = when name = inner -> () | Instance_of name, Some ((InstanceType (Class _) | ObjectType) as inner) -> - (* A public abbreviation is the same type as the superclass, unless it - is a strict instance of it, as in the phantom type hierarchy - [type element<'a> = node<_element<'a>>]. The arguments are read after - expansion, where the superclass type is reached. *) - let same_type = - match (Ctype.expand_head_opt env manifest).desc with - | Tconstr (_, args, _) -> List.for_all Btype.is_Tvar args - | _ -> true - in + (* 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}) -> @@ -161,7 +154,7 @@ let check_manifest_annotation ~loc ~env (decl : Types.type_declaration) = (* Every class instance is an object *) | _ -> ("Object", []) in - if decl.type_private = Public && same_type then + 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 -> diff --git a/tests/build_tests/super_errors/expected/instance_of_public_subclass_instance.res.expected b/tests/build_tests/super_errors/expected/instance_of_public_subclass_instance.res.expected new file mode 100644 index 00000000000..19d6165e9b6 --- /dev/null +++ b/tests/build_tests/super_errors/expected/instance_of_public_subclass_instance.res.expected @@ -0,0 +1,9 @@ + + We've found a bug for you! + /.../fixtures/instance_of_public_subclass_instance.res:2:20-41 + + 1 │ @instanceOf("Animal") type animal<'a> + 2 │ @instanceOf("Dog") type dog = animal + 3 │ + + A subclass must be a private abbreviation: write `= private ...` so that instances of Animal cannot be used as instances of Dog without a coercion. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/instance_of_public_subclass_instance.res b/tests/build_tests/super_errors/fixtures/instance_of_public_subclass_instance.res new file mode 100644 index 00000000000..cdd22c2883e --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/instance_of_public_subclass_instance.res @@ -0,0 +1,2 @@ +@instanceOf("Animal") type animal<'a> +@instanceOf("Dog") type dog = animal diff --git a/tests/tests/src/untagged_runtime_annotations_test.res b/tests/tests/src/untagged_runtime_annotations_test.res index 37ec02e2d09..2394c89fa7c 100644 --- a/tests/tests/src/untagged_runtime_annotations_test.res +++ b/tests/tests/src/untagged_runtime_annotations_test.res @@ -94,12 +94,12 @@ let localeKind = locale => | Tag(tag) => tag } -// A phantom type hierarchy declares subclasses with public abbreviations that -// are strict instances of their superclass type +// A phantom type hierarchy declares its subclasses as private abbreviations +// too type nodeLike<'a> @instanceOf("UntaggedAnimal") type animalLike<'a> = nodeLike<'a> type _dog<'a> -@instanceOf("UntaggedDog") type dogLike<'a> = animalLike<_dog<'a>> +@instanceOf("UntaggedDog") type dogLike<'a> = private animalLike<_dog<'a>> type _base @new external makePhantomAnimal: unit => animalLike<_base> = "UntaggedAnimal" @new external makePhantomDog: unit => dogLike<_base> = "UntaggedDog" From ab924c652136ded57a08b95df447e7329ce89446 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 24 Oct 2026 16:18:41 +0000 Subject: [PATCH 14/19] Say precisely when literals use an if and what folds Rule 7 counts the literals that get a case, as the code does, and rule 11 names the values constant folding sees: literals and blocks of constants. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- compiler/ml/UntaggedVariants.md | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/compiler/ml/UntaggedVariants.md b/compiler/ml/UntaggedVariants.md index 0af5468e1c3..fabdbc8bebf 100644 --- a/compiler/ml/UntaggedVariants.md +++ b/compiler/ml/UntaggedVariants.md @@ -281,8 +281,8 @@ constructor: | `@as(null) LitNull \| AnyObject({x: int})` | `LitNull` | `LitNull` | The literals are compared with `===`: by one `switch (x)` over the literal -arms, whose default holds the payload dispatch, or, with at most two -literals, by an `if` per arm body. A literal without an arm of its own goes +arms, whose default holds the payload dispatch, or, when at most two +literals get a `case`, by an `if` per arm body. A literal without an arm of its own goes to the default arm. It gets a `case` leading there when it could pass a check of the payload dispatch (a string literal beside a `string` arm, any literal beside an unknown-kind arm) or when the variant has class cases; @@ -411,9 +411,11 @@ primitives of the variant never reach it. ### 11. Constant folding -A `switch` on a constant untagged value folds to the arm that the run-time -dispatch selects for the constant's JavaScript value, so `S("a")` matched -against `@as("a") A | S(string)` folds to `A`. +A `switch` on an untagged value the compiler knows, a literal or a block of +constants, folds to the arm that the run-time dispatch selects for its +JavaScript value, so `S("a")` matched against `@as("a") A | S(string)` folds +to `A`. A value built at run time, such as `A([1])` with its array, is +matched at run time. - Implementation: `lambda.ml:switch` (`untagged_action`, `literal_denotes_same`). - Tests: `tests/tests/src/unboxed_variant_fold_test.res`. From ad2cc33206b7617f901cece9d5855023406d8ac9 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 24 Oct 2026 16:21:10 +0000 Subject: [PATCH 15/19] Emit untagged checks directly instead of through Dynamic_checks The check AST in Ast_untagged_variants only encoded the int-tag test of tagged variants and the instance checks. Js_exp_make now builds both directly (is_int_tag from the literal list, is_instance_of), and matching_facts no longer carries has_null, has_undefined and has_other_literal, which that test derived. A class is never a switch key, so block_type_name no longer pretends to emit one. No output changes. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- compiler/core/js_exp_make.ml | 65 +++++++++---------- compiler/core/js_exp_make.mli | 5 +- compiler/core/lam_compile.ml | 25 ++----- compiler/ml/ast_untagged_variants.ml | 40 ------------ compiler/ml/variant_runtime.ml | 17 +---- compiler/ml/variant_runtime.mli | 3 - .../ounit_tests/ounit_string_literal_tests.ml | 6 +- 7 files changed, 43 insertions(+), 118 deletions(-) diff --git a/compiler/core/js_exp_make.ml b/compiler/core/js_exp_make.ml index c7d10c264cf..5d3a5814dec 100644 --- a/compiler/core/js_exp_make.ml +++ b/compiler/core/js_exp_make.ml @@ -1395,45 +1395,44 @@ let class_constructor (instance : Variant_runtime.Instance.t) = | [] -> assert false | global :: properties -> List.fold_left dot (js_global global) properties -(* The [typeof] string an untagged payload answers to. *) -let block_type_name = function - | Variant_runtime.InstanceType i -> class_constructor i - | block_type -> ( - match Variant_runtime.typeof_name block_type with - | Some name -> str name - | None -> - (* An unknown payload has no check: it is the only payload case *) - assert false) +(* The [typeof] string an untagged payload answers to, as a [switch] key. + Instances are told apart by [is_instance_of], an unknown payload is not + checked *) +let block_type_name block_type = + match Variant_runtime.typeof_name block_type with + | Some name -> str name + | None -> assert false let tag_type = function | Variant_runtime.Literal d -> literal_tag d | Payload_shape b -> block_type_name b -let rec emit_check (check : t Ast_untagged_variants.Dynamic_checks.t) = - match check with - | TagType t -> tag_type t - | BinOp (op, x, y) -> - let op = - match op with - | EqEqEq -> Js_op.EqEqEq - | NotEqEq -> NotEqEq - | And -> And - | Or -> Or - in - bin op (emit_check x) (emit_check y) - | TypeOf x -> typeof (emit_check x) - | IsInstanceOf (Array, x) -> is_array (emit_check x) - | IsInstanceOf (instance, x) -> - instanceof (emit_check x) (class_constructor instance) - | Not x -> not (emit_check x) - | Expr x -> x - -let is_int_tag ?has_null_undefined_other e = - let check = - Ast_untagged_variants.Dynamic_checks.is_int_tag ?has_null_undefined_other - (Expr e) +let is_instance_of (instance : Variant_runtime.Instance.t) e = + match instance with + | Array -> is_array e + | Class _ -> instanceof e (class_constructor instance) + +(* Whether a value of a tagged variant is a constant rather than a block, + given the literals of its constants *) +let is_int_tag ~(literal_tags : Variant_runtime.literal_tag list) e = + let has_null = List.mem Variant_runtime.Null literal_tags in + let has_undefined = List.mem Variant_runtime.Undefined literal_tags in + let has_other = + List.exists + (function + | Variant_runtime.Null | Undefined -> false + | String _ | Int _ | Float _ | BigInt _ | Bool _ -> true) + literal_tags in - emit_check check + let is_null = bin EqEqEq e nil in + let is_undefined = bin EqEqEq e undefined in + let not_an_object = bin NotEqEq (typeof e) (str "object") in + match (has_null, has_undefined, has_other) with + | true, false, false -> is_null + | true, true, false -> bin Or is_null is_undefined + | false, true, false -> is_undefined + | true, _, true -> bin Or is_null not_an_object + | false, _, _ -> not_an_object let tag ?comment ?(name = Js_dump_lit.tag) e : t = {expression_desc = Caml_block_tag (e, name); comment; source_loc = None} diff --git a/compiler/core/js_exp_make.mli b/compiler/core/js_exp_make.mli index a699f2e2605..e1622ec8e02 100644 --- a/compiler/core/js_exp_make.mli +++ b/compiler/core/js_exp_make.mli @@ -164,7 +164,8 @@ val assign : ?comment:string -> t -> t -> t val literal_tag : Variant_runtime.literal_tag -> t val tag_type : Variant_runtime.tag_type -> t -val emit_check : t Ast_untagged_variants.Dynamic_checks.t -> t +val is_instance_of : Variant_runtime.Instance.t -> t -> t +(** [Array.isArray(e)] or [e instanceof C] *) val triple_equal : ?comment:string -> t -> t -> t (* TODO: reduce [triple_equal] use *) @@ -179,7 +180,7 @@ val eq_null_undefined_boolean : ?comment:string -> t -> t -> t val neq_null_undefined_boolean : ?comment:string -> t -> t -> t -val is_int_tag : ?has_null_undefined_other:bool * bool * bool -> t -> t +val is_int_tag : literal_tags:Variant_runtime.literal_tag list -> t -> t val is_type_object : t -> t diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index 228e880a2a6..640d2602072 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -186,20 +186,9 @@ let tag_of_switch_key : _ -> Variant_runtime.tag_type option = function Some (Payload_shape block_type) let dispatch_info = function - | Lambda.Switch_direct -> (Js_dump_lit.tag, [], [], (false, false, false)) - | Switch_variant - { - Variant_runtime.tag_name; - block_types; - literal_tags; - has_null; - has_undefined; - has_other_literal; - } -> - ( Option.value tag_name ~default:Js_dump_lit.tag, - block_types, - literal_tags, - (has_null, has_undefined, has_other_literal) ) + | Lambda.Switch_direct -> (Js_dump_lit.tag, [], []) + | Switch_variant {Variant_runtime.tag_name; block_types; literal_tags} -> + (Option.value tag_name ~default:Js_dump_lit.tag, block_types, literal_tags) let no_effects_const = lazy true (* let has_effects_const = lazy false *) @@ -762,9 +751,7 @@ let compile output_prefix = let sw_blocks_default = default_action ~saturated:sw_blocks_full sw_failaction in - let tag_name, block_cases, literal_cases, has_null_undefined_other = - dispatch_info sw_dispatch - in + let tag_name, block_cases, literal_cases = dispatch_info sw_dispatch in let untagged = block_cases <> [] in let compile_whole (cxt : Lam_compile_context.t) = match @@ -947,7 +934,7 @@ let compile output_prefix = else [ S.if_ - (E.is_int_tag ~has_null_undefined_other e) + (E.is_int_tag ~literal_tags:literal_cases e) (compile_cases ~cxt ~switch_exp:e ~block_cases ~default:sw_num_default sw_consts) ~else_: @@ -1051,7 +1038,7 @@ let compile output_prefix = | Variant_runtime.Instance.Class _ -> true | Array -> false in - let check_instance i = E.emit_check (IsInstanceOf (i, Expr e)) in + let check_instance i = E.is_instance_of i e in let typeof_is name = E.string_equal (E.typeof e) (E.str name) in (* [null], when it did not go to the default before *) let is_object = diff --git a/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml index 47c4d6d2921..bb11cb85a7d 100644 --- a/compiler/ml/ast_untagged_variants.ml +++ b/compiler/ml/ast_untagged_variants.ml @@ -562,43 +562,3 @@ let check_tag_field_conflicts (cstrs : Types.constructor_declaration list) = fields | _ -> ()) cstrs - -module Dynamic_checks = struct - type op = EqEqEq | NotEqEq | Or | And - type 'a t = - | BinOp of op * 'a t * 'a t - | TagType of tag_type - | TypeOf of 'a t - | IsInstanceOf of Instance.t * 'a t - | Not of 'a t - | Expr of 'a - - let bin op x y = BinOp (op, x, y) - let tag_type t = TagType t - let typeof x = TypeOf x - let nil = Literal Null |> tag_type - let undefined = Literal Undefined |> tag_type - let object_ = Payload_shape ObjectType |> tag_type - - let ( == ) x y = bin EqEqEq x y - let ( != ) x y = bin NotEqEq x y - let ( ||| ) x y = bin Or x y - - let is_int_tag ?(has_null_undefined_other = (false, false, false)) (e : _ t) : - _ t = - let has_null, has_undefined, has_other = has_null_undefined_other in - if has_null && has_undefined = false && has_other = false then - (* null *) - bin EqEqEq e nil - else if has_null && has_undefined && has_other = false then - (* null + undefined *) - e == nil ||| e == undefined - else if has_null = false && has_undefined && has_other = false then - (* undefined *) - e == undefined - else if has_null then - (* (null + undefined + other) || (null + other) *) - e == nil ||| typeof e != object_ - else (* (undefiled + other) || other *) - typeof e != object_ -end diff --git a/compiler/ml/variant_runtime.ml b/compiler/ml/variant_runtime.ml index 61f8f328185..726a2ac8e19 100644 --- a/compiler/ml/variant_runtime.ml +++ b/compiler/ml/variant_runtime.ml @@ -129,9 +129,6 @@ type matching_facts = { payload constructor only receives values that are not literals, and [S("a")] matches as [A]: constructor identity is not observable at runtime for such values. *) - has_null: bool; - has_undefined: bool; - has_other_literal: bool; } (** Declaration-level facts needed when lowering a constructor match. This is not an occurrence-specific matching plan: it contains no arms, actions, @@ -197,18 +194,9 @@ let compute_matching_facts ~tag_name (constructors : constructor_case array) : matching_facts = let block_types = ref [] in let literal_tags = ref [] in - let has_null = ref false in - let has_undefined = ref false in - let has_other_literal = ref false in Array.iter (function - | Constant {literal} -> ( - literal_tags := literal :: !literal_tags; - match literal with - | Null -> has_null := true - | Undefined -> has_undefined := true - | String _ | Int _ | Float _ | BigInt _ | Bool _ -> - has_other_literal := true) + | Constant {literal} -> literal_tags := literal :: !literal_tags | Block (Untagged {block_type}) -> block_types := block_type :: !block_types | Block (Tagged _) -> ()) @@ -217,9 +205,6 @@ let compute_matching_facts ~tag_name (constructors : constructor_case array) : tag_name; block_types = List.rev !block_types; literal_tags = List.rev !literal_tags; - has_null = !has_null; - has_undefined = !has_undefined; - has_other_literal = !has_other_literal; } let make_layout ~(configuration : configuration) constructors = diff --git a/compiler/ml/variant_runtime.mli b/compiler/ml/variant_runtime.mli index 8eaf4e7b60e..a08b211c28a 100644 --- a/compiler/ml/variant_runtime.mli +++ b/compiler/ml/variant_runtime.mli @@ -94,9 +94,6 @@ type matching_facts = { tag_name: string option; block_types: block_type list; literal_tags: literal_tag list; - has_null: bool; - has_undefined: bool; - has_other_literal: bool; } type layout diff --git a/tests/ounit_tests/ounit_string_literal_tests.ml b/tests/ounit_tests/ounit_string_literal_tests.ml index f95904db709..4839155e763 100644 --- a/tests/ounit_tests/ounit_string_literal_tests.ml +++ b/tests/ounit_tests/ounit_string_literal_tests.ml @@ -774,14 +774,10 @@ let suites = | _ -> OUnit.assert_failure "expected Array.isArray simplification to remain active"); - let open Ast_untagged_variants.Dynamic_checks in let date = Variant_runtime.Instance.Class {name = "Date"; ancestors = []} in - assert_js_global ~expected:"Date" - (Js_exp_make.emit_check - (TagType (Variant_runtime.Payload_shape (InstanceType date)))); - match Js_exp_make.emit_check (IsInstanceOf (date, Expr value)) with + match Js_exp_make.is_instance_of date value with | {expression_desc = Bin (InstanceOf, argument, constructor)} -> OUnit.assert_bool "expected the original argument" (Js_analyzer.eq_expression value argument); From 7139b2784b1c50da3cc64f8cc86ec1d92d53ce58 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 24 Oct 2026 16:23:03 +0000 Subject: [PATCH 16/19] Share which literal passes which payload check Code generation and constant folding each had a table of the literals a payload case accepts, and they disagreed on null and an object case. Variant_runtime.literal_passes is now the one table; folding follows the generated code, where `typeof null` is "object", so null without a null case folds into the object case as it is matched at run time. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- compiler/core/lam_compile.ml | 18 ++---------------- compiler/ml/lambda.ml | 11 +++++------ compiler/ml/variant_runtime.ml | 14 ++++++++++++++ compiler/ml/variant_runtime.mli | 5 +++++ .../ounit_tests/ounit_lambda_constant_tests.ml | 9 +++++++++ 5 files changed, 35 insertions(+), 22 deletions(-) diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index 640d2602072..b7a2d56fa5c 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -792,23 +792,9 @@ let compile output_prefix = (* A tagged block, an object *) Some Variant_runtime.ObjectType) in - let reaches_a_payload_arm (literal : Variant_runtime.literal_tag) - = + let reaches_a_payload_arm literal = List.exists - (fun (block_type : Variant_runtime.block_type) -> - match (block_type, literal) with - | UnknownType, _ - | StringType, String _ - | NumberType, (Int _ | Float _) - | BigintType, BigInt _ - | BooleanType, Bool _ - | ObjectType, Null -> - true - | ( ( StringType | NumberType | BigintType | BooleanType - | ObjectType | InstanceType _ | SymbolType - | FunctionType ), - _ ) -> - false) + (Variant_runtime.literal_passes literal) payload_arms in let has_class_case = diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 942936dd4ca..71cc84490b2 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -846,19 +846,18 @@ let runtime_value_kind (c : structured_constant) = Integer tags are emitted through [Int32.of_int], just like [Const_int]. *) let literal_denotes_same = Variant_runtime.same_literal_value -(* Mirror [Dynamic_checks]: literals take precedence; the object case excludes - arrays when an array case exists. Int and float share one runtime type. *) +(* Whether the payload dispatch sends a value of this kind to a case of this + block type. Literals are checked as the generated code checks them; the + object case excludes arrays when an array case exists. *) let value_has_block_type ~block_types (kind : value_kind) (block_type : Variant_runtime.block_type) = match (block_type, kind) with - | NumberType, Is_literal (Int _ | Float _) -> true - | StringType, Is_literal (String _) -> true - | BooleanType, Is_literal (Bool _) -> true + | _, Is_literal literal -> Variant_runtime.literal_passes literal block_type | ObjectType, Is_object -> true | InstanceType Array, Is_array -> true | ObjectType, Is_array -> not (List.mem (Variant_runtime.InstanceType Array) block_types) - | UnknownType, (Is_literal _ | Is_object | Is_array) -> true + | UnknownType, (Is_object | Is_array) -> true | UnknownType, Unknown_value -> false | ( ( NumberType | StringType | BooleanType | ObjectType | BigintType | SymbolType | FunctionType | InstanceType _ ), diff --git a/compiler/ml/variant_runtime.ml b/compiler/ml/variant_runtime.ml index 726a2ac8e19..341beab920b 100644 --- a/compiler/ml/variant_runtime.ml +++ b/compiler/ml/variant_runtime.ml @@ -94,6 +94,20 @@ let same_literal_value a b = literal_value_key a = literal_value_key b (** Information used to recognize a constructor during matching. A literal identifies a constant or an object's tag; a payload shape identifies a value represented directly by its payload. *) +let literal_passes (literal : literal_tag) (block_type : block_type) = + match (block_type, literal) with + | UnknownType, _ + | StringType, String _ + | NumberType, (Int _ | Float _) + | BigintType, BigInt _ + | BooleanType, Bool _ + | ObjectType, Null -> + true + | ( ( StringType | NumberType | BigintType | BooleanType | ObjectType + | InstanceType _ | SymbolType | FunctionType ), + _ ) -> + false + type tag_type = Literal of literal_tag | Payload_shape of block_type type tag = {name: string; literal: literal_tag} diff --git a/compiler/ml/variant_runtime.mli b/compiler/ml/variant_runtime.mli index a08b211c28a..1d57cd6fa0e 100644 --- a/compiler/ml/variant_runtime.mli +++ b/compiler/ml/variant_runtime.mli @@ -61,6 +61,11 @@ val literal_value_key : literal_tag -> string val same_literal_value : literal_tag -> literal_tag -> bool +val literal_passes : literal_tag -> block_type -> bool +(** Whether a literal passes the check of a payload case of this kind, as + [typeof] sees it: ["a"] a string case, [null] an object case, anything an + unknown case, which is not checked *) + (** Information used to recognize a constructor during matching. A literal identifies a constant or an object's tag; a payload shape identifies a value represented directly by its payload. *) diff --git a/tests/ounit_tests/ounit_lambda_constant_tests.ml b/tests/ounit_tests/ounit_lambda_constant_tests.ml index 732be64d80a..8b674b5cba4 100644 --- a/tests/ounit_tests/ounit_lambda_constant_tests.ml +++ b/tests/ounit_tests/ounit_lambda_constant_tests.ml @@ -139,6 +139,15 @@ let switch_tests = ( Lambda.blk_record [|("x", false)|] Asttypes.Immutable, [Const_int 1l] )) "object" ); + ( "null without a null case is an object" >:: fun _ -> + let record = block "Record" ObjectType in + let text = block "Text" StringType in + let sw = + variant_switch ~constructors:[record; text] + ~cases:[(record, "record"); (text, "text")] + ~default:None + in + assert_fold sw Const_js_null "record" ); ( "empty list is zero at runtime" >:: fun _ -> let zero = literal "Zero" (Int 0) in let values = block "Values" UnknownType in From 18bb267167066bae8f4d315e5d1378940fec7afe Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 24 Oct 2026 16:23:56 +0000 Subject: [PATCH 17/19] Move the variant invariant check next to the layout check_invariant checks a layout, and Variant_layout, which derives the layout, is its only caller; Ast_untagged_variants keeps the attributes and errors. Its doc comment, which described another function, now says what it checks. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- compiler/ml/UntaggedVariants.md | 2 +- compiler/ml/ast_untagged_variants.ml | 150 --------------------------- compiler/ml/variant_layout.ml | 150 +++++++++++++++++++++++++++ 3 files changed, 151 insertions(+), 151 deletions(-) diff --git a/compiler/ml/UntaggedVariants.md b/compiler/ml/UntaggedVariants.md index fabdbc8bebf..514099c892c 100644 --- a/compiler/ml/UntaggedVariants.md +++ b/compiler/ml/UntaggedVariants.md @@ -257,7 +257,7 @@ A literal may equal a value of a payload case: `@as("a") A | S(string)`, `@as(true) A | B(bool)` are accepted. Rule 7 says which case such a value belongs to. -- Implementation: `ast_untagged_variants.ml:check_invariant`, +- Implementation: `variant_layout.ml:check_invariant`, `variant_runtime.ml:literal_value_key`. - Tests: the fixtures above; `tests/tests/src/unboxed_variant_fold_test.res` (a number and a bigint literal with the same digits); `TaggedDuplicateLiteral.res`, diff --git a/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml index bb11cb85a7d..59f78345349 100644 --- a/compiler/ml/ast_untagged_variants.ml +++ b/compiler/ml/ast_untagged_variants.ml @@ -379,156 +379,6 @@ let is_nullary_variant (x : Types.constructor_arguments) = | Types.Cstr_tuple [] -> true | _ -> false -(* A literal's JavaScript value, which a [switch] compares with [===]. Ints - are emitted as 32-bit numbers, so [1], [1.0] and [4294967297] are one - number, while [1n] is a bigint. *) -let check_invariant ~is_untagged_def ~(consts : (Location.t * tag) list) - ~(blocks : (Location.t * block) list) = - let module String_set = Set.Make (String) in - let module String_map = Map.Make (String) in - let string_literals_consts = ref String_set.empty in - let string_literals_blocks = ref String_set.empty in - (* Keyed by [literal_key], with the spelling of the literal *) - let nonstring_literals_consts = ref String_map.empty in - let nonstring_literals_blocks = ref String_map.empty in - let instance_types = Hashtbl.create 1 in - let function_types = ref 0 in - let object_types = ref 0 in - let string_types = ref 0 in - let number_types = ref 0 in - let bigint_types = ref 0 in - let boolean_types = ref 0 in - let symbol_types = ref 0 in - let unknown_types = ref 0 in - let add_string_literal ~is_const ~loc s = - let set = - if is_const then string_literals_consts else string_literals_blocks - in - if String_set.mem s !set then - raise (Error (loc, InvalidUntaggedVariantDefinition (DuplicateLiteral s))); - set := String_set.add s !set - in - let add_nonstring_literal ~is_const ~loc literal s = - let map = - if is_const then nonstring_literals_consts else nonstring_literals_blocks - in - let key = Variant_runtime.literal_value_key literal in - (match String_map.find_opt key !map with - | Some earlier when earlier = s -> - raise (Error (loc, InvalidUntaggedVariantDefinition (DuplicateLiteral s))) - | Some earlier -> - raise - (Error - ( loc, - InvalidUntaggedVariantDefinition (SameLiteralValue (s, earlier)) )) - | None -> ()); - map := String_map.add key s !map - in - let invariant loc name = - if !unknown_types <> 0 && List.length blocks <> 1 then - raise - (Error (loc, InvalidUntaggedVariantDefinition (OnlyOneUnknown name))); - if !object_types > 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneObject)); - Hashtbl.iter - (fun _ (i, count) -> - if count > 1 then - raise - (Error (loc, InvalidUntaggedVariantDefinition (AtMostOneInstance i)))) - instance_types; - if !function_types > 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneFunction)); - if !string_types > 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneString)); - if !number_types > 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneNumber)); - if !bigint_types > 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneBigint)); - if !boolean_types > 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneBoolean)); - if !symbol_types > 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneSymbol)); - () - in - let check_literal ~is_const ~loc (tag : tag) = - match tag.literal with - | String s -> add_string_literal ~is_const ~loc s - | Int i as literal -> - add_nonstring_literal ~is_const ~loc literal (string_of_int i) - | Float f as literal -> add_nonstring_literal ~is_const ~loc literal f - | BigInt i as literal -> - add_nonstring_literal ~is_const ~loc literal (i ^ "n") - | Bool b as literal -> - add_nonstring_literal ~is_const ~loc literal - (if b then "true" else "false") - | Null as literal -> add_nonstring_literal ~is_const ~loc literal "null" - | Undefined as literal -> - add_nonstring_literal ~is_const ~loc literal "undefined" - in - - Ext_list.rev_iter consts (fun (loc, literal) -> - check_literal ~is_const:true ~loc literal); - (* A tagged block is told apart from the others by its tag; an untagged one - is 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 _ -> ()); - (* The payload kinds are checked as soon as one case is untagged, even when - the type itself is not [@unboxed] *) - let has_untagged_block = - List.exists - (function - | _, Untagged _ -> true - | _, Tagged _ -> false) - blocks - in - if is_untagged_def || has_untagged_block then ( - (* Tagged blocks are objects with a tag field: together one object case *) - if - List.exists - (function - | _, Tagged _ -> true - | _, Untagged _ -> false) - blocks - then incr object_types; - Ext_list.rev_iter blocks (fun (loc, block) -> - match block with - | 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 - | Tagged _ -> ())) - (* A constructor without [@as] is represented by its name *) let declared_tag (cstr : Types.constructor_declaration) = let name = Ident.name cstr.cd_id in diff --git a/compiler/ml/variant_layout.ml b/compiler/ml/variant_layout.ml index 40eb5e26ce7..04479f14c19 100644 --- a/compiler/ml/variant_layout.ml +++ b/compiler/ml/variant_layout.ml @@ -193,6 +193,156 @@ 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, untagged payloads by distinct kinds, + checked as soon as one case is untagged *) +let check_invariant ~is_untagged_def ~(consts : (Location.t * tag) list) + ~(blocks : (Location.t * block) list) = + let module String_set = Set.Make (String) in + let module String_map = Map.Make (String) in + let string_literals_consts = ref String_set.empty in + let string_literals_blocks = ref String_set.empty in + (* Keyed by [literal_key], with the spelling of the literal *) + let nonstring_literals_consts = ref String_map.empty in + let nonstring_literals_blocks = ref String_map.empty in + let instance_types = Hashtbl.create 1 in + let function_types = ref 0 in + let object_types = ref 0 in + let string_types = ref 0 in + let number_types = ref 0 in + let bigint_types = ref 0 in + let boolean_types = ref 0 in + let symbol_types = ref 0 in + let unknown_types = ref 0 in + let add_string_literal ~is_const ~loc s = + let set = + if is_const then string_literals_consts else string_literals_blocks + in + if String_set.mem s !set then + raise (Error (loc, InvalidUntaggedVariantDefinition (DuplicateLiteral s))); + set := String_set.add s !set + in + let add_nonstring_literal ~is_const ~loc literal s = + let map = + if is_const then nonstring_literals_consts else nonstring_literals_blocks + in + let key = Variant_runtime.literal_value_key literal in + (match String_map.find_opt key !map with + | Some earlier when earlier = s -> + raise (Error (loc, InvalidUntaggedVariantDefinition (DuplicateLiteral s))) + | Some earlier -> + raise + (Error + ( loc, + InvalidUntaggedVariantDefinition (SameLiteralValue (s, earlier)) )) + | None -> ()); + map := String_map.add key s !map + in + let invariant loc name = + if !unknown_types <> 0 && List.length blocks <> 1 then + raise + (Error (loc, InvalidUntaggedVariantDefinition (OnlyOneUnknown name))); + if !object_types > 1 then + raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneObject)); + Hashtbl.iter + (fun _ (i, count) -> + if count > 1 then + raise + (Error (loc, InvalidUntaggedVariantDefinition (AtMostOneInstance i)))) + instance_types; + if !function_types > 1 then + raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneFunction)); + if !string_types > 1 then + raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneString)); + if !number_types > 1 then + raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneNumber)); + if !bigint_types > 1 then + raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneBigint)); + if !boolean_types > 1 then + raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneBoolean)); + if !symbol_types > 1 then + raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneSymbol)); + () + in + let check_literal ~is_const ~loc (tag : tag) = + match tag.literal with + | String s -> add_string_literal ~is_const ~loc s + | Int i as literal -> + add_nonstring_literal ~is_const ~loc literal (string_of_int i) + | Float f as literal -> add_nonstring_literal ~is_const ~loc literal f + | BigInt i as literal -> + add_nonstring_literal ~is_const ~loc literal (i ^ "n") + | Bool b as literal -> + add_nonstring_literal ~is_const ~loc literal + (if b then "true" else "false") + | Null as literal -> add_nonstring_literal ~is_const ~loc literal "null" + | Undefined as literal -> + add_nonstring_literal ~is_const ~loc literal "undefined" + in + + Ext_list.rev_iter consts (fun (loc, literal) -> + check_literal ~is_const:true ~loc literal); + (* A tagged block is told apart from the others by its tag; an untagged one + is 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 _ -> ()); + (* The payload kinds are checked as soon as one case is untagged, even when + the type itself is not [@unboxed] *) + let has_untagged_block = + List.exists + (function + | _, Untagged _ -> true + | _, Tagged _ -> false) + blocks + in + if is_untagged_def || has_untagged_block then ( + (* Tagged blocks are objects with a tag field: together one object case *) + if + List.exists + (function + | _, Tagged _ -> true + | _, Untagged _ -> false) + blocks + then incr object_types; + Ext_list.rev_iter blocks (fun (loc, block) -> + match block with + | 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 + | Tagged _ -> ())) + let layout_from_type_variant ~(configuration : configuration) ~env (cstrs : Types.constructor_declaration list) : Variant_runtime.layout = let get_block (cstr : Types.constructor_declaration) : block = From 19cd7e9260ccdd67ff040321dc32ec8d562d4763 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 24 Oct 2026 16:25:36 +0000 Subject: [PATCH 18/19] Compare every runtime shape claim of an interface in one place Interface inclusion compared classes and kinds in Includecore and @notUndefined in Includemod, the two levels of one declared shape. Includecore.compare_runtime_annotations now checks both; the messages are unchanged. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- compiler/ml/UntaggedVariants.md | 2 +- compiler/ml/includecore.ml | 22 +++++++++++++++++----- compiler/ml/includemod.ml | 20 -------------------- 3 files changed, 18 insertions(+), 26 deletions(-) diff --git a/compiler/ml/UntaggedVariants.md b/compiler/ml/UntaggedVariants.md index 514099c892c..ad064e9c913 100644 --- a/compiler/ml/UntaggedVariants.md +++ b/compiler/ml/UntaggedVariants.md @@ -501,7 +501,7 @@ for functor arguments and `with type` constraints. `ast_untagged_variants.ml:has_not_undefined`; `variant_layout.ml:declaration_shape`; `typeopt.ml:type_cannot_contain_undefined`; - `includemod.ml:not_undefined_mismatch`. + `includecore.ml:compare_runtime_annotations`. - Tests: `spec_test` rule 13; fixtures `invalid_attribute_not_undefined.res`, `not_undefined_functor_argument.res`, `not_undefined_functor_parameter.res`; `tests/tests/src/not_undefined_interface_test.res`, diff --git a/compiler/ml/includecore.ml b/compiler/ml/includecore.ml index 62d1546b67e..fe6bdee2714 100644 --- a/compiler/ml/includecore.ml +++ b/compiler/ml/includecore.ml @@ -345,13 +345,25 @@ and compare_records env params1_ params2_ n_ in aux ~fast:true params1_ params2_ n_ labels1_ labels2_ -(* Values are recognized by the class or [typeof] the second declaration - states, so the first must state the same. Stating nothing hides it. *) -let compare_runtime_annotations env decl1 decl2 = +(* What the second declaration states about its values at run time must + hold for the first. Values are recognized by the class or [typeof] the + second states, so the first must state the same; stating nothing hides it. + [@notUndefined] lets clients unbox [option] of the type, so the first must + be a type that cannot hold [undefined] either, or one whose representation + the compiler does not see, which has none that contradicts it. *) +let compare_runtime_annotations env id decl1 decl2 = (* The second declaration's shape was resolved in its own environment, so it is what users of the second declaration see *) match decl2.type_shape with - | Unstated | Never_undefined -> [] + | Unstated -> [] + | Never_undefined -> ( + let env = Env.add_type ~check:false id decl1 env in + let ty = + Btype.newgenty (Tconstr (Pident id, decl1.type_params, ref Mnil)) + in + match Typeopt.undefinedness env ty with + | Cannot_be_undefined | Unseen -> [] + | Stands_for_another | Can_be_undefined -> [Not_undefined]) | Recognized_as block_type2 -> let declared2 = Some block_type2 in let declared1 = @@ -395,7 +407,7 @@ let type_declarations ?(equality = false) ~loc env name decl1 id decl2 = else [Constraint] in let err = - if err <> [] then err else compare_runtime_annotations env decl1 decl2 + if err <> [] then err else compare_runtime_annotations env id decl1 decl2 in if err <> [] then err else diff --git a/compiler/ml/includemod.ml b/compiler/ml/includemod.ml index fbd64367ad8..890c6c97ded 100644 --- a/compiler/ml/includemod.ml +++ b/compiler/ml/includemod.ml @@ -62,32 +62,12 @@ let value_descriptions ~loc env cxt subst id vd1 vd2 = (* Inclusion between type declarations *) -(* [@notUndefined] lets clients unbox [option] of the type, so the - implementation must be a type that cannot hold [undefined] either, or one - whose representation the compiler does not see, which has none that - contradicts it. *) -let not_undefined_mismatch env id (decl1 : Types.type_declaration) - (decl2 : Types.type_declaration) = - match decl2.type_shape with - | Unstated | Recognized_as _ -> [] - | Never_undefined -> ( - let env = Env.add_type ~check:false id decl1 env in - let ty = - Btype.newgenty (Tconstr (Pident id, decl1.type_params, ref Mnil)) - in - match Typeopt.undefinedness env ty with - | Cannot_be_undefined | Unseen -> [] - | Stands_for_another | Can_be_undefined -> [Includecore.Not_undefined]) - let type_declarations ~loc env ?(old_env = env) cxt subst id decl1 decl2 = Env.mark_type_used env (Ident.name id) decl1; let decl2 = Subst.type_declaration subst decl2 in let err = Includecore.type_declarations ~loc env (Ident.name id) decl1 id decl2 in - let err = - if err <> [] then err else not_undefined_mismatch env id decl1 decl2 - in if err <> [] then raise (Error [(cxt, old_env, Type_declarations (id, decl1, decl2, err))]) From be31af5586edf1f875d831eb5183f58999ccd7d5 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sun, 25 Oct 2026 05:11:52 +0000 Subject: [PATCH 19/19] Merge the @notUndefined rule into the rule on declared shapes `@notUndefined`, `@typeOf` and `@instanceOf` declare levels of one stored shape, checked on abbreviations by one entry point and across interfaces by one comparer. Rule 5 now describes the three together, with their errors and interface checks; rule 13 is gone and the rule on `@tag` and interfaces becomes rule 13. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- compiler/ml/UntaggedVariants.md | 162 ++++++++---------- .../tests/src/untagged_variants_spec_test.mjs | 4 +- .../tests/src/untagged_variants_spec_test.res | 4 +- 3 files changed, 75 insertions(+), 95 deletions(-) diff --git a/compiler/ml/UntaggedVariants.md b/compiler/ml/UntaggedVariants.md index ad064e9c913..ddb3dc0e525 100644 --- a/compiler/ml/UntaggedVariants.md +++ b/compiler/ml/UntaggedVariants.md @@ -116,20 +116,28 @@ builtin payload type. `@notUndefined` on an abstract type leaves it unknown. `untagged_builtin_alias_test.res`. - Shaped by #6121, #6208, #6219, #6279, #6368, #6394, #6550, #6670. -### 5. Declared instance types +### 5. Declared runtime shapes -`@instanceOf("C")` on a type declares that its values are instances of the -global class at the path `C`, such as `"Date"` or `"Intl.Locale"`. -`@typeOf("k")` declares that their `typeof` is `k`, one of `"string"`, -`"number"`, `"bigint"`, `"boolean"`, `"symbol"`, `"function"` and -`"object"`. A type has at most one of the two, and only abstract types and -type abbreviations, public or private, can have them. +Three annotations declare what the values of a type are at run time, each +level implying the one before: + +- `@notUndefined`: they are never `undefined`; +- `@typeOf("k")`: their `typeof` is `k`, one of `"string"`, `"number"`, + `"bigint"`, `"boolean"`, `"symbol"`, `"function"` and `"object"`; +- `@instanceOf("C")`: they are instances of the global class at the path `C`, + such as `"Date"` or `"Intl.Locale"`. + +A type has at most one of `@typeOf` and `@instanceOf`, and only abstract types +and type abbreviations, public or private, can have any of the three. +`@notUndefined` affects only rule 12: `option` of the type, and of an untagged +variant with a payload of the type, is unboxed. It does not make the type a +recognized payload kind (rule 4). When a type is declared, its annotation is resolved into its *shape*, which -is stored on the declaration: the class with its superclasses, or the -`typeof` kind (`@notUndefined` gives the shape "never undefined", rule 13). -The classes annotated further down a chain of abbreviations are the -superclasses (rule 8): +is stored on the declaration: "never undefined", the `typeof` kind, or the +class with its superclasses. The builtin types state their shapes in their +declarations (rule 4). The classes annotated further down a chain of +abbreviations are the superclasses (rule 8): ```rescript @instanceOf("Animal") type animal @@ -140,14 +148,16 @@ The classifier and every other reader take the shape of the payload type as written, or of the first type it abbreviates that states one, so the outermost annotation decides. A shape is resolved in the environment the type is declared in, so an interface's shape is what its users see, even -where the implementation knows more (rule 14). An annotation that repeats +where the implementation knows more. An annotation that repeats the abbreviated type's, as the declarations of a module alias do, adds no superclass. An annotation on an abbreviation must agree with the abbreviated type. It can -refine an abstract type that is not builtin and has no annotation, or repeat -what the abbreviated type is recognized by, as `@typeOf("number") type count = -int` does. The type of a functor parameter, of a +refine a type whose representation the compiler does not see, an abstract +type that is not builtin and has no annotation, or restate what the +abbreviated type is known to be, as `@typeOf("number") type count = int` and +`@notUndefined type count = int` do; a restating `@notUndefined` keeps the +kind of `int`. The type of a functor parameter, of a recursive module being defined, and a locally abstract type `(type a)` are abstract only where they are declared: they stand for another type, so they cannot be refined. Only a private abbreviation can declare a subclass of the @@ -160,14 +170,34 @@ would `type dog = animal` or `type dog = phantom` with | Declaration | Error | Fixture | | --- | --- | --- | | `@typeOf("string") type t = option`, `type t<'a> = 'a`, an abbreviation of `unit`, `list<_>`, a record or a variant | @typeOf on a type abbreviation must describe an abstract type, ... | `runtime_annotation_on_option.res`, `runtime_annotation_on_type_variable.res` | +| `@notUndefined type t = option` | @notUndefined on a type abbreviation must describe an abstract type, ... | `not_undefined_on_option.res`, `tests/build_tests/not_undefined_attribute` | | `@typeOf("number") type t = sym` with `@typeOf("symbol") type sym`, or `@typeOf("string") type t = int` | This annotation, @typeOf("number"), contradicts the abbreviated type, whose values are recognized by @typeOf("symbol"). | `runtime_annotation_contradicts_manifest.res`, `runtime_annotation_contradicts_builtin.res` | -| `@instanceOf("Date") type date = X.t` in a functor of `X`, or over `(type a)` | @instanceOf cannot describe the type of a functor parameter, ... | `instance_of_functor_parameter.res`, `type_of_locally_abstract_type.res` | +| `@instanceOf("Date") type date = X.t` in a functor of `X`, or over `(type a)`; `@notUndefined type t = X.t` | @instanceOf cannot describe the type of a functor parameter, ... | `instance_of_functor_parameter.res`, `type_of_locally_abstract_type.res`, `not_undefined_on_functor_parameter_type.res` | | `@instanceOf("Dog") type dog = animal`, `= animal`, or `= phantom` with `type phantom<'a> = animal` | A subclass must be a private abbreviation ... | `instance_of_public_subclass.res`, `instance_of_public_subclass_instance.res`, `instance_of_public_subclass_through_alias.res` | | `@instanceOf("Animal") type t = private dog` | Animal appears twice in this chain of abbreviations ... | `instance_of_class_twice_in_chain.res` | -| `@instanceOf` on a record or variant | @instanceOf can only be used on abstract types and type abbreviations ... | `runtime_annotation_on_record.res` | -| both annotations | A type can have either @instanceOf or @typeOf, not both. | `runtime_annotation_conflict.res` | +| any of the three on a record or variant | @instanceOf can only be used on abstract types and type abbreviations ... | `runtime_annotation_on_record.res`, `invalid_attribute_not_undefined.res` | +| both `@instanceOf` and `@typeOf` | A type can have either @instanceOf or @typeOf, not both. | `runtime_annotation_conflict.res` | | one annotation twice | Duplicate @instanceOf annotation; a type can have only one. | `instance_of_duplicate.res` | +What an interface states about a type must hold for its implementation. A +class or `typeof`, stated through its own annotation or the type it +abbreviates, must be the one the implementation states, superclasses +included: "Their runtime representations differ". A builtin type states its +kind, so `@typeOf("number") type t` in an interface accepts `type t = int` +(`untagged_builtin_alias_test.res`). Under `@notUndefined`, the +implementation must be a type that cannot hold `undefined` either, or one +whose representation the compiler does not see, which has none to contradict +it: an abstract type, also through an abbreviation such as +`type t = Dom.element`, or a JavaScript object type; a functor parameter's or +a locally abstract type stands for another type and does not count. +`type t = option` under `@notUndefined type t` is an error: "the second +declaration is @notUndefined, but the first declaration can hold undefined". +An interface that states nothing hides the shape. The same holds for functor +arguments, `with type` constraints and module type ascriptions. Within one +variant a class is identified by its path, so two types of the same class are +one case (rule 6); across a signature the two declarations must also state +the same superclasses. + The class path is a dot-separated list of identifiers whose first one is not a JavaScript keyword. Paths that name no class to recognize values by are rejected as well: @@ -205,16 +235,26 @@ written (Known bugs). - Implementation: `types.mli:type_shape`, `variant_runtime.mli:value_shape`; `variant_layout.ml:declaration_shape`, `resolve_shapes`, `value_shape`, `check_manifest_annotation`; - `ast_untagged_variants.ml:process_runtime_annotation`, `unsupported_class`, - `check_runtime_annotation`; + `typedecl.ml:check_manifest_annotations`; `typeopt.ml:undefinedness`; + `ast_untagged_variants.ml:process_runtime_annotation`, `has_not_undefined`, + `unsupported_class`, `check_runtime_annotation`; + `includecore.ml:compare_runtime_annotations`; `variant_runtime.ml:Instance`; `js_exp_make.ml:class_constructor`. - Tests: `spec_test` rules 4 and 5; `tests/tests/src/untagged_runtime_annotations_test.res`, `untagged_runtime_annotations_shadow_test.res`, - `untagged_file_blob_test.res`; the fixtures above, - `UntaggedAtMostOneInstance.res`, `UntaggedTupleAndArray.res`. -- Shaped by #6296, #6383, #6396, #7788, #8009, #8950, #8948, #8949. - Related: #7147. + `untagged_file_blob_test.res`, `not_undefined_interface_test.res`, + `not_undefined_abbreviation_test.res`; the fixtures above, + `UntaggedAtMostOneInstance.res`, `UntaggedTupleAndArray.res`, + `not_undefined_functor_argument.res`, `not_undefined_functor_parameter.res`; + `tests/build_tests/super_errors_multi/fixtures/` + `Cross_runtime_annotation_hidden_superclass`, + `Cross_runtime_annotation_hidden_base`, + `Cross_runtime_annotation_claimed_by_interface`, + `Cross_runtime_annotation_functor_argument`, + `Cross_not_undefined_option_implementation`. +- Shaped by #6296, #6383, #6396, #7458, #7464, #7788, #8009, #8950, #8948, + #8949, #8964. Related: #7147. ### 6. Well-formedness @@ -433,7 +473,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 | @@ -466,51 +506,7 @@ hold `undefined`. `tests/build_tests/option_transitive_dependency`. - Shaped by #6222, #6233, #8719, #8954. -### 13. `@notUndefined` - -`@notUndefined` on an abstract type declares that its values are never -`undefined`. It affects only rule 12: `option` of the type, and of an -untagged variant with a payload of the type, is unboxed. It does not make the -type a recognized payload kind (rule 4). `@instanceOf` and `@typeOf` (rule 5) -imply it. - -On an abbreviation it follows the rule of rule 5: it can refine a type whose -representation the compiler does not see, such as an abstract type, or -restate that the abbreviated type cannot be `undefined`, as -`@notUndefined type count = int` does, which keeps the kind of `int`. - -| Declaration | Error | Fixture | -| --- | --- | --- | -| `@notUndefined type t = {x: int}`, or on a variant | @notUndefined can only be used on abstract types and type abbreviations, ... | `invalid_attribute_not_undefined.res` | -| `@notUndefined type t = option` | @notUndefined on a type abbreviation must describe an abstract type, ... | `not_undefined_on_option.res`, `tests/build_tests/not_undefined_attribute` | -| `@notUndefined type t = X.t` in a functor of `X` | @notUndefined cannot describe the type of a functor parameter, ... | `not_undefined_on_functor_parameter_type.res` | - -When an interface declares a type `@notUndefined`, its implementation must be -a type that cannot hold `undefined` either, or a type whose representation -the compiler does not see, which has none to contradict it: an abstract type, -also through an abbreviation such as `type t = Dom.element`, or a JavaScript -object type. The type of a functor parameter or a locally abstract type -stands for another type and does not count as abstract. `type t = option` under -`@notUndefined type t` is an error: "Their runtime representations -differ: the second declaration is @notUndefined, but the first declaration -can hold undefined". The same holds -for functor arguments and `with type` constraints. - -- Implementation: `typedecl.ml:transl_declaration`, - `check_not_undefined_manifest`; `typeopt.ml:undefinedness`; - `ast_untagged_variants.ml:has_not_undefined`; - `variant_layout.ml:declaration_shape`; - `typeopt.ml:type_cannot_contain_undefined`; - `includecore.ml:compare_runtime_annotations`. -- Tests: `spec_test` rule 13; fixtures `invalid_attribute_not_undefined.res`, - `not_undefined_functor_argument.res`, `not_undefined_functor_parameter.res`; - `tests/tests/src/not_undefined_interface_test.res`, - `not_undefined_abbreviation_test.res`; - `tests/build_tests/super_errors_multi/fixtures/Cross_not_undefined_option_implementation`; - `tests/build_tests/not_undefined_attribute`. -- Shaped by #7458, #7464, #8964. - -### 14. `@tag` and interfaces +### 13. `@tag` and interfaces In a tagged variant, `@tag("f")` names the field that holds the tag of a case with a payload (`TAG` by default), and `@as` on such a case sets the tag's @@ -527,29 +523,14 @@ not checked, so it agrees with any payload of the implementation payload does not change its representation (rule 2) and is not compared. Type declarations in messages print the `@as` of nullary and tagged cases. -A type for which an interface states a class or `typeof` (rule 5), through -its own annotation or the type it abbreviates, must state the same one in the -implementation, superclasses included: "Their runtime representations -differ". A builtin type states its kind, so `@typeOf("number") type t` in an -interface accepts `type t = int` (`untagged_builtin_alias_test.res`). An -interface that states none hides it. The same holds for functor -arguments, `with type` constraints and module type ascriptions. Within one -variant a class is identified by its path, so two types of the same class are -one case (rule 6); across a signature the two declarations must also state -the same superclasses. - - Implementation: `variant_layout.ml:layout_from_type_variant`, `ast_untagged_variants.ml:process_tag_name`, `check_tag_field_conflicts`; `includecore.ml:compare_variants`, `type_declarations`. -- Tests: `spec_test` rule 14; fixtures `UntaggedTagFieldNameConflict.res`, +- Tests: `spec_test` rule 13; fixtures `UntaggedTagFieldNameConflict.res`, `variant_tag_overlaps_with_field.res`, `UntaggedInvalidVariantTagAnnotation.res`, `UntaggedImplIntf.res`; `tests/build_tests/super_errors_multi/fixtures/` `Iface_unboxed_variant_mismatch`, `Iface_tag_name_mismatch`, - `Iface_variant_representation_mismatch`, - `Cross_runtime_annotation_hidden_superclass`, - `Cross_runtime_annotation_hidden_base`, - `Cross_runtime_annotation_claimed_by_interface`, - `Cross_runtime_annotation_functor_argument`; `variant_payload_tag_mismatch.res`. + `Iface_variant_representation_mismatch`; `variant_payload_tag_mismatch.res`. - Shaped by #6498, #6513, #6669, #7875, #8956. ## Known bugs @@ -578,15 +559,14 @@ had to answer, and the answers of rule 5: down its chain of private abbreviations. A superclass case excludes its subclass cases in any order, and an upcast value lands in the subclass case (rule 8). The relation must be visible where the variant is declared: an interface that - hides it is rejected (rule 14). + hides it is rejected (rule 5). 3. **Overlaps across kinds.** `Object`, `Function`, `Array` and the wrappers of primitives are rejected as classes. A declared kind counts as the builtin kind (rule 6). Unrelated classes are tested in declaration order. 4. **The unchecked branch** stays the contract (rule 10). 5. **Realms.** Recognition is local to a realm (rule 10). -6. **Interfaces and functors** compare declared classes and kinds, and the - payload kinds of untagged cases (rule 14), and `@notUndefined` against - the implementation (rule 13). +6. **Interfaces and functors** compare declared shapes (rule 5) and the + payload kinds of untagged cases (rule 13). 7. **Implied `@notUndefined`.** A declared class or kind implies it, and rule 5 rejects annotations on abbreviations of types that can hold `undefined`. diff --git a/tests/tests/src/untagged_variants_spec_test.mjs b/tests/tests/src/untagged_variants_spec_test.mjs index cd70cf0e170..4c4bfbd2c8a 100644 --- a/tests/tests/src/untagged_variants_spec_test.mjs +++ b/tests/tests/src/untagged_variants_spec_test.mjs @@ -357,11 +357,11 @@ Mocha.describe("Untagged_variants_spec_test", () => { Test_utils.eq("File \"untagged_variants_spec_test.res\", line 337, characters 7-14", someWithUnboxedOption(undefined) === undefined, false); Test_utils.eq("File \"untagged_variants_spec_test.res\", line 338, 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 342, characters 7-14", someWithDefined(undefined) === undefined, true); Test_utils.eq("File \"untagged_variants_spec_test.res\", line 343, 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 347, 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 b9cf3d08f2c..a806547fcfc 100644 --- a/tests/tests/src/untagged_variants_spec_test.res +++ b/tests/tests/src/untagged_variants_spec_test.res @@ -338,12 +338,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")