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/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/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/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/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/js_exp_make.ml b/compiler/core/js_exp_make.ml index 5b29dc33066..5d3a5814dec 100644 --- a/compiler/core/js_exp_make.ml +++ b/compiler/core/js_exp_make.ml @@ -1395,52 +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_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 - (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 70f6e7326f8..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,13 +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_a_literal_case : - literal_cases:Variant_runtime.literal_tag list -> - block_cases:Variant_runtime.block_type list -> - 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/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..b7a2d56fa5c 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -164,37 +164,31 @@ 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 | 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)) - | 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 *) @@ -564,6 +558,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 +571,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 +593,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 +649,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) -> @@ -690,20 +695,18 @@ 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) ?(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 @@ -748,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 @@ -761,7 +762,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 +771,160 @@ 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 (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 + 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 (Payload_shape block_type) -> Some block_type + | Some (Literal _) | 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 = + List.exists + (Variant_runtime.literal_passes literal) + 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 + (* 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 -> + 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 ~literal_tags:literal_cases 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 +960,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.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 = + 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 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 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 = 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/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/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/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 01929fe9700..ddb3dc0e525 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 @@ -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`, @@ -114,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 @@ -138,34 +148,56 @@ The classifier and every other reader take the shape of the payload type as written, or of the first type it abbreviates that states one, so the outermost annotation decides. A shape is resolved in the environment the type is declared in, so an interface's shape is what its users see, even -where the implementation knows more (rule 14). An annotation that repeats +where the implementation knows more. An annotation that repeats the abbreviated type's, as the declarations of a module alias do, adds no superclass. An annotation on an abbreviation must agree with the abbreviated type. It can -refine an abstract type that is not builtin and has no annotation, or repeat -the annotation of the abbreviated type. The type of a functor parameter, of a +refine a type whose representation the compiler does not see, an abstract +type that is not builtin and has no annotation, or restate what the +abbreviated type is known to be, 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 -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`, a builtin type, a record or a variant | @typeOf on a type abbreviation must describe an abstract type, ... | `runtime_annotation_on_option.res`, `runtime_annotation_on_type_variable.res` | -| `@typeOf("number") type t = sym` with `@typeOf("symbol") type sym` | This annotation, @typeOf("number"), contradicts the abbreviated type's annotation, @typeOf("symbol"). | `runtime_annotation_contradicts_manifest.res` | -| `@instanceOf("Date") type date = X.t` in a functor of `X`, or over `(type a)` | @instanceOf cannot describe the type of a functor parameter, ... | `instance_of_functor_parameter.res`, `type_of_locally_abstract_type.res` | -| `@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` | +| `@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)`; `@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: @@ -203,21 +235,37 @@ 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 -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 | | --- | --- | --- | @@ -249,7 +297,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`, @@ -272,71 +320,98 @@ 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, 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; +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). + +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` - (choice of expression). -- 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 -The payload arms compile in one of two forms. - -- **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. +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: -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,40 +421,41 @@ 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 -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`. @@ -397,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 | @@ -430,39 +506,7 @@ hold `undefined`. `tests/build_tests/option_transitive_dependency`. - Shaped by #6222, #6233, #8719, #8954. -### 13. `@notUndefined` - -`@notUndefined` on an abstract type without a manifest declares that its -values are never `undefined`. It affects only rule 12: `option` of the type, -and of an untagged variant with a payload of the type, is unboxed. It does not -make the type a recognized payload kind (rule 4). On any other type -declaration it is an error, "@notUndefined can only be used on abstract -types". `@instanceOf` and `@typeOf` (rule 5) imply it. - -When an interface declares a type `@notUndefined`, its implementation must be -a type that cannot hold `undefined` either, or a type whose representation -the compiler does not see, which has none to contradict it: an abstract type, -also through an abbreviation such as `type t = Dom.element`, or a JavaScript -object type. The type of a functor parameter or a locally abstract type -stands for another type and does not count as abstract. `type t = option` under -`@notUndefined type t` is an error: "Their runtime representations -differ: the second declaration is @notUndefined, but the first declaration -can hold undefined". The same holds -for functor arguments and `with type` constraints. - -- Implementation: `typedecl.ml:transl_declaration`; - `ast_untagged_variants.ml:has_not_undefined`; - `variant_layout.ml:declaration_shape`; - `typeopt.ml:type_cannot_contain_undefined`; - `includemod.ml:not_undefined_mismatch`. -- Tests: `spec_test` rule 13; fixtures `invalid_attribute_not_undefined.res`, - `not_undefined_functor_argument.res`, `not_undefined_functor_parameter.res`; - `tests/tests/src/not_undefined_interface_test.res`; - `tests/build_tests/super_errors_multi/fixtures/Cross_not_undefined_option_implementation`; - `tests/build_tests/not_undefined_attribute`. -- Shaped by #7458, #7464, #8964. - -### 14. `@tag` and interfaces +### 13. `@tag` and interfaces In a tagged variant, `@tag("f")` names the field that holds the tag of a case with a payload (`TAG` by default), and `@as` on such a case sets the tag's @@ -472,33 +516,21 @@ error. An interface and its implementation must agree on `@unboxed`, on `@tag`, on the literal of every nullary case and of every tagged case with a payload, and on the payload kind of every untagged case whose kind the interface -knows. An unknown payload in the interface is its only payload case and is +knows. A case without `@as` has the literal of its name, so `A` and +`@as("A") A` agree, here and in coercions (`as_constructor_name_test.res`). An unknown payload in the interface is its only payload case and is not checked, so it agrees with any payload of the implementation (`untagged_hidden_payload_test.res`). The `@as` of an untagged case with a payload does not change its representation (rule 2) and is not compared. Type declarations in messages print the `@as` of nullary and tagged cases. -A type for which an interface states a class or `typeof` (rule 5), through -its own annotation or the type it abbreviates, must state the same one in the -implementation, superclasses included: "Their runtime representations -differ". An interface that states none hides it. The same holds for functor -arguments, `with type` constraints and module type ascriptions. Within one -variant a class is identified by its path, so two types of the same class are -one case (rule 6); across a signature the two declarations must also state -the same superclasses. - - Implementation: `variant_layout.ml:layout_from_type_variant`, `ast_untagged_variants.ml:process_tag_name`, `check_tag_field_conflicts`; `includecore.ml:compare_variants`, `type_declarations`. -- Tests: `spec_test` rule 14; fixtures `UntaggedTagFieldNameConflict.res`, +- Tests: `spec_test` rule 13; fixtures `UntaggedTagFieldNameConflict.res`, `variant_tag_overlaps_with_field.res`, `UntaggedInvalidVariantTagAnnotation.res`, `UntaggedImplIntf.res`; `tests/build_tests/super_errors_multi/fixtures/` `Iface_unboxed_variant_mismatch`, `Iface_tag_name_mismatch`, - `Iface_variant_representation_mismatch`, - `Cross_runtime_annotation_hidden_superclass`, - `Cross_runtime_annotation_hidden_base`, - `Cross_runtime_annotation_claimed_by_interface`, - `Cross_runtime_annotation_functor_argument`; `variant_payload_tag_mismatch.res`. + `Iface_variant_representation_mismatch`; `variant_payload_tag_mismatch.res`. - Shaped by #6498, #6513, #6669, #7875, #8956. ## Known bugs @@ -524,19 +556,17 @@ 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). + 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`. @@ -545,6 +575,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..59f78345349 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 @@ -369,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} @@ -378,161 +379,13 @@ 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 - | None -> add_string_literal ~is_const ~loc tag.name - | Some (String s) -> add_string_literal ~is_const ~loc s - | Some (Int i as literal) -> - add_nonstring_literal ~is_const ~loc literal (string_of_int i) - | Some (Float f as literal) -> - add_nonstring_literal ~is_const ~loc literal f - | Some (BigInt i as literal) -> - add_nonstring_literal ~is_const ~loc literal (i ^ "n") - | Some (Bool b as literal) -> - add_nonstring_literal ~is_const ~loc literal - (if b then "true" else "false") - | Some (Null as literal) -> - add_nonstring_literal ~is_const ~loc literal "null" - | Some (Undefined as literal) -> - add_nonstring_literal ~is_const ~loc literal "undefined" - in - - Ext_list.rev_iter consts (fun (loc, literal) -> - check_literal ~is_const:true ~loc literal); - (* 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 + {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 @@ -559,191 +412,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 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 = - 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_ - - (* 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/ctype.ml b/compiler/ml/ctype.ml index 51d926eaae2..b1326f398a7 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -3580,7 +3580,7 @@ let rec subtype_rec env trace t1 t2 cstrs = Variant_coercion.can_try_coerce_variant_to_primitive_opt (extract_concrete_typedecl_opt env t2) with - | Some (p, _, _, false) -> + | Some (p, _, false) -> (* Not @unboxed *) ( trace, t1, @@ -3590,7 +3590,7 @@ let rec subtype_rec env trace t1 t2 cstrs = (Coercion_target_variant_not_unboxed {variant_name = p; primitive = path}) ) :: cstrs - | Some (p, constructors, _, true) -> + | Some (p, constructors, true) -> if Variant_coercion.variant_has_case_covering_type constructors ~path_is_same_fn:(fun p -> Path.same p path) @@ -3622,12 +3622,12 @@ let rec subtype_rec env trace t1 t2 cstrs = Variant_coercion.can_try_coerce_variant_to_primitive_opt (extract_concrete_typedecl_opt env t1) with - | Some (p, constructors, layout, unboxed) -> + | Some (p, constructors, unboxed) -> let runtime_representation_issues = constructors |> Variant_coercion .variant_has_same_runtime_representation_as_target - ~target_path:path ~unboxed ~layout + ~target_path:path ~unboxed in if List.length runtime_representation_issues <> 0 then ( trace, @@ -3857,7 +3857,7 @@ let rec subtype_rec env trace t1 t2 cstrs = in match Variant_coercion.can_coerce_polyvariant_to_variant ~row_fields - ~variant_constructors ~layout ~unboxed + ~variant_constructors ~unboxed with | Ok _ -> cstrs | Error _ -> @@ -4391,3 +4391,35 @@ let get_arity env typ = module For_test = struct let previous_env_is_empty () = !(previous_env ()) == Env.empty end + +(* We use the expand_head_opt version of expand_head to get access + to the manifest type of private abbreviations. *) +let rec get_unboxed_type_representation env ty fuel = + if fuel < 0 then None + else + let ty = repr (expand_head_opt env ty) in + match ty.desc with + | Tconstr (p, args, _) -> ( + match Env.find_type p env with + | exception Not_found -> Some ty + | {type_representation = Boxed} -> Some ty + | { + type_params; + type_kind = + ( Type_record ([{ld_type = ty2; _}], _) + | Type_variant ([{cd_args = Cstr_tuple [ty2]; _}], _) + | Type_variant ([{cd_args = Cstr_record [{ld_type = ty2; _}]; _}], _) ); + } -> + get_unboxed_type_representation env + (apply env type_params ty2 args) + (fuel - 1) + | {type_kind = Type_abstract} -> + None + (* This case can occur when checking a recursive unboxed type + declaration. *) + | _ -> assert false (* only the above can be unboxed *)) + | _ -> Some ty + +let get_unboxed_type_representation env ty = + (* Do not give too much fuel: PR#7424 *) + get_unboxed_type_representation env ty 100 diff --git a/compiler/ml/ctype.mli b/compiler/ml/ctype.mli index 2b3087037f8..09bea4bbb9c 100644 --- a/compiler/ml/ctype.mli +++ b/compiler/ml/ctype.mli @@ -347,3 +347,7 @@ module For_test : sig (** The environment of the last expansion on this domain is still the initial empty one. *) end + +val get_unboxed_type_representation : Env.t -> type_expr -> type_expr option +(** The type an [@unboxed] wrapper is represented by, through any number of + wrappers *) diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index 8665b0c6fb8..67031fa22e9 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -704,9 +704,8 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf let constructor_name = Ident.name cd.cd_id in let runtime_repr = match Variant_runtime.constructor_tag layout position with - | Some (String s) -> Some s (* @as("string_value") *) - | Some _ -> None (* @as with non-string values *) - | None -> Some constructor_name (* No @as, use constructor name *) + | String s -> Some s + | Int _ | Float _ | BigInt _ | Bool _ | Null | Undefined -> None in match runtime_repr with | Some repr -> Some (repr, constructor_name) diff --git a/compiler/ml/includecore.ml b/compiler/ml/includecore.ml index 62d1546b67e..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 08f44bbe4ae..890c6c97ded 100644 --- a/compiler/ml/includemod.ml +++ b/compiler/ml/includemod.ml @@ -62,42 +62,12 @@ let value_descriptions ~loc env cxt subst id vd1 vd2 = (* Inclusion between type declarations *) -(* [@notUndefined] lets clients unbox [option] of the type, so the - implementation must be a type that cannot hold [undefined] either. A type - whose representation the compiler does not see, an abstract type (also - through an abbreviation) or a JavaScript object type, has none that - contradicts it. A functor parameter's or a locally abstract type stands - for any type, so it does not count as abstract. *) -let not_undefined_mismatch env id (decl1 : Types.type_declaration) - (decl2 : Types.type_declaration) = - match decl2.type_shape with - | Unstated | Recognized_as _ -> [] - | Never_undefined -> - let env = Env.add_type ~check:false id decl1 env in - let ty = - Btype.newgenty (Tconstr (Pident id, decl1.type_params, ref Mnil)) - in - let opaque = - match (Ctype.expand_head_opt env ty).desc with - | Tconstr (path, _, _) -> ( - match Variant_layout.abstractness ~env path with - | Opaque -> true - | Stands_for_another | Not_abstract -> false) - | Tobject _ -> true - | _ -> false - in - if opaque || Typeopt.type_cannot_contain_undefined ty env then [] - else [Includecore.Not_undefined] - let type_declarations ~loc env ?(old_env = env) cxt subst id decl1 decl2 = Env.mark_type_used env (Ident.name id) decl1; let decl2 = Subst.type_declaration subst decl2 in let err = Includecore.type_declarations ~loc env (Ident.name id) decl1 id decl2 in - let err = - if err <> [] then err else not_undefined_mismatch env id decl1 decl2 - in if err <> [] then raise (Error [(cxt, old_env, Type_declarations (id, decl1, decl2, err))]) diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 33443e420e1..71cc84490b2 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -422,7 +422,7 @@ let const_constructor (tag : Variant_runtime.tag) = if tag.name = "()" then const_unit else match tag.literal with - | Some (Variant_runtime.Int v) -> Const_int (Int32.of_int v) + | Variant_runtime.Int v when tag.name <> "[]" -> Const_int (Int32.of_int v) | _ -> Const_constructor tag (* A constructor with an optional shape carries no payload when constant. *) @@ -588,7 +588,7 @@ let rec const_some_none_depth (c : structured_constant) : int = if depth < 0 then depth else depth + 1 | Const_module_alias | Const_js_undefined _ (* A constructor represented by [undefined], [@as(undefined)] *) - | Const_constructor {literal = Some Undefined} -> + | Const_constructor {literal = Undefined} -> 0 | _ -> -1 @@ -825,10 +825,8 @@ let runtime_value_kind (c : structured_constant) = | Const_js_null -> Is_literal Null | Const_js_undefined _ -> Is_literal Undefined | Const_polyvar name -> Is_literal (String name) - | Const_constructor {name = "[]"; literal = None} -> Is_literal (Int 0) - | Const_constructor {name; literal = None} -> Is_literal (String name) - | Const_constructor {literal = Some (BigInt _)} -> Unknown_value - | Const_constructor {literal = Some literal} -> Is_literal literal + | Const_constructor {literal = BigInt _} -> Unknown_value + | Const_constructor {literal} -> Is_literal literal | Const_block (Blk_tuple, _) -> Is_array | Const_block (Blk_record {fields}, _) -> if record_fields_are_array fields then Is_array else Is_object @@ -848,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 _ ), @@ -888,11 +885,6 @@ let switch lam (lam_switch : lambda_switch) : t = | Switch_constructor case when matches case -> Some action | Switch_int _ | Switch_constructor _ -> None)) in - let literal_of_tag (tag : Variant_runtime.tag) = - match tag.literal with - | Some literal -> literal - | None -> Variant_runtime.String tag.name - in let matches_block = value_has_block_type ~block_types:facts.block_types in let kind = runtime_value_kind cst in match kind with @@ -901,7 +893,7 @@ let switch lam (lam_switch : lambda_switch) : t = when Ext_list.exists facts.literal_tags (literal_denotes_same literal) -> (* The literal side wins, exactly as it does at runtime. *) find_in lam_switch.sw_consts (function - | Constant tag -> literal_denotes_same literal (literal_of_tag tag) + | Constant tag -> literal_denotes_same literal tag.literal | Block _ -> false) | Is_literal _ | Is_object | Is_array -> (* Not a declared literal, so the payload's runtime shape decides. *) @@ -916,11 +908,13 @@ let switch lam (lam_switch : lambda_switch) : t = match untagged_action facts cst with | `Case action -> action_or_switch action | `Undecided -> Lswitch (lam, lam_switch)) - | Lconst (Const_constructor cstr_name), _ -> + | Lconst (Const_constructor constant), _ -> + (* By runtime value: a coercion accepts [@as(1.)] for [@as(1.0)] *) let action = Ext_list.find_opt lam_switch.sw_consts (fun (key, action) -> match key with - | Switch_constructor (Constant tag) when cstr_name = tag -> + | Switch_constructor (Constant tag) + when literal_denotes_same constant.literal tag.literal -> Some action | Switch_int _ | Switch_constructor _ -> None) in @@ -933,9 +927,9 @@ let switch lam (lam_switch : lambda_switch) : t = Ext_list.find_opt lam_switch.sw_consts (fun (key, action) -> match key with | Switch_int ordinal when ordinal = i -> Some action - | Switch_constructor - (Constant {literal = Some (Variant_runtime.Int value)}) - when value = i -> + | Switch_constructor (Constant {literal}) + when literal_denotes_same (Int i) literal -> + (* A constant represented as a number, compared by value *) Some action | Switch_int _ | Switch_constructor _ -> None) in @@ -949,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) @@ -1016,13 +1018,14 @@ let prim ~primitive:(prim : primitive) ~args loc : t = | Cneq -> a <> b | _ -> assert false) | ( Pintcomp ((Ceq | Cneq) as op), - Const_constructor {name = a; literal = None}, - Const_constructor {name = b; literal = None} ) -> - (* Both runtime representations are the constructor names *) + Const_constructor {literal = a}, + Const_constructor {literal = b} ) -> + (* Constants are compared by their runtime values *) + let same = Variant_runtime.same_literal_value a b in Lift.bool (match op with - | Ceq -> a = b - | Cneq -> a <> b + | Ceq -> same + | Cneq -> not same | _ -> assert false) | ( ( Paddint | Psubint | Pmulint | Pdivint | Pmodint | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint ), @@ -1173,15 +1176,14 @@ let rec eval_const_as_bool (v : structured_constant) : bool option = | Const_bigint _ | Const_block _ -> Some true | Const_some b -> eval_const_as_bool b - | Const_constructor {name; literal} -> ( + | Const_constructor {literal} -> ( (* Truthiness of the canonical runtime representation *) match literal with - | None -> Some (name <> "[]") (* the name string; [] is the number 0 *) - | Some (String s) -> Some (s <> "") - | Some (Int i) -> Some (i <> 0) - | Some (Bool b) -> Some b - | Some (Null | Undefined) -> Some false - | Some (Float _ | BigInt _) -> None) + | String s -> Some (s <> "") + | Int i -> Some (i <> 0) + | Bool b -> Some b + | Null | Undefined -> Some false + | Float _ | BigInt _ -> None) let if_ (a : t) (b : t) (c : t) : t = match a with diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index d768ff18dba..bd469b6c93f 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -1455,7 +1455,7 @@ let rec rejects_nested_some p = | Ordinary_constructor representation when not (Datarepr.constructor_has_optional_shape cstr) -> ( match Variant_runtime.representation representation with - | Constant {literal} -> literal <> Some Variant_runtime.Undefined + | Constant {literal} -> literal <> Variant_runtime.Undefined | Block (Untagged {block_type = ObjectType | UnknownType}) -> false | Block (Untagged _) -> true | Block (Tagged _) -> false) @@ -2293,7 +2293,7 @@ and switch_defaults_on_undefined (sw : lambda_switch) = && List.for_all (function | Switch_constructor (Constant {literal}), _ -> - literal <> Some Variant_runtime.Undefined + literal <> Variant_runtime.Undefined | _ -> true) sw.sw_consts | Switch_direct -> false diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index 15557ec177b..beb35fce470 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,43 @@ 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 + 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 | [] -> () + | 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,20 +2496,23 @@ 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); 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 *) @@ -2361,8 +2537,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/compiler/ml/predef.ml b/compiler/ml/predef.ml index 8ed35b7056d..f7e134ca3a9 100644 --- a/compiler/ml/predef.ml +++ b/compiler/ml/predef.ml @@ -258,11 +258,17 @@ let plain_variant (cstrs : Types.constructor_declaration list) = cstrs) ) let common_initial_env add_type add_extension empty_env = + (* What [typeof] or [instanceof] recognizes a builtin type's values by, + as an annotation states it for a declared type *) + let recognized_as block_type decl = + {decl with type_shape = Recognized_as block_type} + in let decl_bool = { decl_abstr with type_kind = plain_variant [cstr ident_false []; cstr ident_true []]; type_immediate = true; + type_shape = Recognized_as BooleanType; } and decl_unit = { @@ -278,6 +284,7 @@ let common_initial_env add_type add_extension empty_env = type_params = [tvar]; type_arity = 1; type_variance = [Variance.full]; + type_shape = Recognized_as (InstanceType Array); } and decl_iterable = let tvar = newgenvar () in @@ -333,6 +340,7 @@ let common_initial_env add_type add_extension empty_env = type_params = [tvar]; type_arity = 1; type_variance = [Variance.full]; + type_shape = Recognized_as ObjectType; } and decl_unknown = let tvar = newgenvar () in @@ -362,6 +370,8 @@ let common_initial_env add_type add_extension empty_env = type_params = [tvar]; type_arity = 1; type_variance = [Variance.covariant]; + type_shape = + Recognized_as (InstanceType (Class {name = "Promise"; ancestors = []})); } and decl_tagged_template = let tvar1, tvar2 = (newgenvar (), newgenvar ()) in @@ -393,10 +403,10 @@ let common_initial_env add_type add_extension empty_env = in empty_env |> add_type ident_bool decl_bool - |> add_type ident_int decl_abstr_imm - |> add_type ident_float decl_abstr - |> add_type ident_bigint decl_abstr - |> add_type ident_string decl_abstr + |> add_type ident_int (recognized_as NumberType decl_abstr_imm) + |> add_type ident_float (recognized_as NumberType decl_abstr) + |> add_type ident_bigint (recognized_as BigintType decl_abstr) + |> add_type ident_string (recognized_as StringType decl_abstr) |> add_type ident_unit decl_unit |> add_type ident_exn decl_exn |> add_type ident_option decl_option diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index 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/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 fce5edc493d..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 @@ -100,7 +100,7 @@ let rec cannot_contain_undefined ~visiting (typ : Types.type_expr) (env : Env.t) | Variant_runtime.Block (Tagged {tag}) -> (tag, false) | Variant_runtime.Block (Untagged {tag}) -> (tag, true) in - tag.literal <> Some Variant_runtime.Undefined + tag.literal <> Variant_runtime.Undefined && ((not payload_is_unboxed) || match cd.cd_args with @@ -122,6 +122,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_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 de2a3e4c1fa..04479f14c19 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 @@ -140,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}) -> @@ -156,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 -> @@ -169,23 +167,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) @@ -209,10 +193,160 @@ 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 = - 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 e9ae3595894..341beab920b 100644 --- a/compiler/ml/variant_runtime.ml +++ b/compiler/ml/variant_runtime.ml @@ -94,12 +94,25 @@ 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 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 +124,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} @@ -126,7 +134,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 @@ -134,9 +143,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, @@ -202,35 +208,17 @@ 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 {name; literal} -> ( - (* Without an [@as], a nullary constructor is its own name. *) - let literal = - match literal with - | Some literal -> literal - | None -> String name - in - literal_tags := literal :: !literal_tags; - 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 _) -> ()) constructors; { tag_name; - block_types = !block_types; - literal_tags = !literal_tags; - has_null = !has_null; - has_undefined = !has_undefined; - has_other_literal = !has_other_literal; + block_types = List.rev !block_types; + literal_tags = List.rev !literal_tags; } let make_layout ~(configuration : configuration) constructors = @@ -259,9 +247,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..1d57cd6fa0e 100644 --- a/compiler/ml/variant_runtime.mli +++ b/compiler/ml/variant_runtime.mli @@ -61,17 +61,19 @@ 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. *) 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 +85,6 @@ type block = type constructor_case = Constant of tag | Block of block -val to_matchable_tag : tag -> matchable_tag -(** Widen a tag as stated by a declaration into one a match can compare - against, which also covers an untagged payload's shape. *) - type configuration = { unboxed: bool; (** Whether the declaration carries [@unboxed]. This is retained even @@ -101,9 +99,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 @@ -119,7 +114,10 @@ val get_layout : layout_ref -> layout val matching_facts : layout -> matching_facts val configuration : layout -> configuration val constructor_at : layout -> int -> constructor_case -val constructor_tag : layout -> int -> literal_tag option + +val constructor_tag : layout -> int -> literal_tag +(** The literal of a constant constructor, or of the tag of a tagged one *) + val representation : constructor_reference -> constructor_case val length : layout -> int val num_constants : layout -> int diff --git a/tests/build_tests/not_undefined_attribute/demo.res b/tests/build_tests/not_undefined_attribute/demo.res index cdd9eb9de18..50134526127 100644 --- a/tests/build_tests/not_undefined_attribute/demo.res +++ b/tests/build_tests/not_undefined_attribute/demo.res @@ -1,2 +1,2 @@ @notUndefined -type t = int +type t = option diff --git a/tests/build_tests/not_undefined_attribute/input.js b/tests/build_tests/not_undefined_attribute/input.js index b37a4d14e27..9b3200c91aa 100644 --- a/tests/build_tests/not_undefined_attribute/input.js +++ b/tests/build_tests/not_undefined_attribute/input.js @@ -10,7 +10,11 @@ const { execBuild, execClean } = setup(import.meta.dirname); const out = await execBuild(); const stderr = normalizeNewlines(stripVTControlCharacters(out.stderr)); -assert.ok(stderr.includes("demo.res:2:1-12")); -assert.ok(stderr.includes("@notUndefined can only be used on abstract types")); +assert.ok(stderr.includes("demo.res:2:1-20")); +assert.ok( + stderr.includes( + "@notUndefined on a type abbreviation must describe an abstract type", + ), +); assert.ok(stderr.includes("Failed to Compile")); await execClean(); diff --git a/tests/build_tests/super_errors/expected/instance_of_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/expected/invalid_attribute_not_undefined.res.expected b/tests/build_tests/super_errors/expected/invalid_attribute_not_undefined.res.expected index fe75ea5d4e1..30f9a87b735 100644 --- a/tests/build_tests/super_errors/expected/invalid_attribute_not_undefined.res.expected +++ b/tests/build_tests/super_errors/expected/invalid_attribute_not_undefined.res.expected @@ -1,9 +1,9 @@ We've found a bug for you! - /.../fixtures/invalid_attribute_not_undefined.res:2:1-12 + /.../fixtures/invalid_attribute_not_undefined.res:2:1-17 1 │ @notUndefined - 2 │ type t = int + 2 │ type t = {x: int} 3 │ - @notUndefined can only be used on abstract types \ No newline at end of file + @notUndefined can only be used on abstract types and type abbreviations, whose runtime representation it describes. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/not_undefined_on_functor_parameter_type.res.expected b/tests/build_tests/super_errors/expected/not_undefined_on_functor_parameter_type.res.expected new file mode 100644 index 00000000000..d9f374df594 --- /dev/null +++ b/tests/build_tests/super_errors/expected/not_undefined_on_functor_parameter_type.res.expected @@ -0,0 +1,11 @@ + + We've found a bug for you! + /.../fixtures/not_undefined_on_functor_parameter_type.res:6:17-28 + + 4 │ }, + 5 │ ) => { + 6 │ @notUndefined type t = X.t + 7 │ } + 8 │ + + @notUndefined cannot describe the type of a functor parameter, of a recursive module being defined, or a locally abstract type: such a type stands for another one, whose values can be anything. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/not_undefined_on_option.res.expected b/tests/build_tests/super_errors/expected/not_undefined_on_option.res.expected new file mode 100644 index 00000000000..720a9d04626 --- /dev/null +++ b/tests/build_tests/super_errors/expected/not_undefined_on_option.res.expected @@ -0,0 +1,8 @@ + + We've found a bug for you! + /.../fixtures/not_undefined_on_option.res:1:15-34 + + 1 │ @notUndefined type t = option + 2 │ + + @notUndefined on a type abbreviation must describe an abstract type, or a type with the same annotation. The abbreviated type already has a runtime representation the compiler knows, or can be undefined. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/runtime_annotation_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/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..6d716a4d874 --- /dev/null +++ b/tests/build_tests/super_errors/expected/warning_12_untagged_literal_shadows_or_pattern.res.expected @@ -0,0 +1,25 @@ + + 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. + + + 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/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/build_tests/super_errors/fixtures/invalid_attribute_not_undefined.res b/tests/build_tests/super_errors/fixtures/invalid_attribute_not_undefined.res index cdd9eb9de18..b57e947694a 100644 --- a/tests/build_tests/super_errors/fixtures/invalid_attribute_not_undefined.res +++ b/tests/build_tests/super_errors/fixtures/invalid_attribute_not_undefined.res @@ -1,2 +1,2 @@ @notUndefined -type t = int +type t = {x: int} diff --git a/tests/build_tests/super_errors/fixtures/not_undefined_on_functor_parameter_type.res b/tests/build_tests/super_errors/fixtures/not_undefined_on_functor_parameter_type.res new file mode 100644 index 00000000000..ee01b578a12 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/not_undefined_on_functor_parameter_type.res @@ -0,0 +1,7 @@ +module Make = ( + X: { + type t + }, +) => { + @notUndefined type t = X.t +} diff --git a/tests/build_tests/super_errors/fixtures/not_undefined_on_option.res b/tests/build_tests/super_errors/fixtures/not_undefined_on_option.res new file mode 100644 index 00000000000..9f6d5044531 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/not_undefined_on_option.res @@ -0,0 +1 @@ +@notUndefined type t = option diff --git a/tests/build_tests/super_errors/fixtures/runtime_annotation_contradicts_builtin.res b/tests/build_tests/super_errors/fixtures/runtime_annotation_contradicts_builtin.res new file mode 100644 index 00000000000..b3e518808cf --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/runtime_annotation_contradicts_builtin.res @@ -0,0 +1 @@ +@typeOf("string") type t = int diff --git a/tests/build_tests/super_errors/fixtures/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..364db46971c --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/warning_12_untagged_literal_shadows_or_pattern.res @@ -0,0 +1,18 @@ +// 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 + } + +// 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 + } 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; } } diff --git a/tests/ounit_tests/ounit_lambda_constant_tests.ml b/tests/ounit_tests/ounit_lambda_constant_tests.ml index d1a470144f2..8b674b5cba4 100644 --- a/tests/ounit_tests/ounit_lambda_constant_tests.ml +++ b/tests/ounit_tests/ounit_lambda_constant_tests.ml @@ -3,16 +3,16 @@ open OUnit let ( =~ ) = OUnit.assert_equal let runtime name : Variant_runtime.tagged_block = - {tag = {name; literal = None}; tag_name = None} + {tag = {name; literal = String name}; tag_name = None} let constructor name = Lambda.Blk_constructor {name; num_nonconst = 1; runtime = runtime name} let literal name value : Variant_runtime.constructor_case = - Constant {name; literal = Some value} + Constant {name; literal = value} let block name shape : Variant_runtime.constructor_case = - Block (Untagged {tag = {name; literal = None}; block_type = shape}) + Block (Untagged {tag = {name; literal = String name}; block_type = shape}) let action s = Lambda.const (Const_string s) @@ -82,7 +82,7 @@ let switch_tests = assert_fold color_switch (Const_string "primary") "literal"; assert_fold color_switch (Const_string "blue") "payload"; assert_fold color_switch - (Const_constructor {name = "Alias"; literal = Some (String "primary")}) + (Const_constructor {name = "Alias"; literal = String "primary"}) "literal" ); ( "declaration literals missing from match select default" >:: fun _ -> let sw = @@ -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 @@ -147,7 +156,8 @@ let switch_tests = ~cases:[(zero, "zero"); (values, "values")] ~default:None in - assert_fold sw (Const_constructor {name = "[]"; literal = None}) "zero" ); + assert_fold sw (Const_constructor {name = "[]"; literal = Int 0}) "zero" + ); ( "unknown values do not select default" >:: fun _ -> let one = literal "One" (BigInt "1") in let value = block "Value" UnknownType in @@ -159,7 +169,7 @@ let switch_tests = List.iter (assert_deferred sw) [ Const_bigint (false, "1"); - Const_constructor {name = "DecimalTen"; literal = Some (BigInt "1_0")}; + Const_constructor {name = "DecimalTen"; literal = BigInt "1_0"}; Const_char 65; Const_some (Const_int 1l); ] ); @@ -191,6 +201,27 @@ let suites = __FILE__ >::: switch_tests @ [ + ( "constant constructors compare by runtime value" >:: fun _ -> + let compare op a b = + Lambda.prim ~primitive:(Pintcomp op) + ~args:[Lambda.const a; Lambda.const b] + Location.none + in + let named = + Lambda.Const_constructor {name = "A"; literal = String "A"} + and declared = + Lambda.Const_constructor {name = "B"; literal = String "A"} + and other = + Lambda.Const_constructor {name = "C"; literal = String "C"} + and number = + Lambda.Const_constructor {name = "D"; literal = Float "1.0"} + and same_number = + Lambda.Const_constructor {name = "E"; literal = Float "1"} + in + Lambda.const Const_js_true =~ compare Ceq named declared; + Lambda.const Const_js_false =~ compare Ceq named other; + Lambda.const Const_js_true =~ compare Cneq named other; + Lambda.const Const_js_true =~ compare Ceq number same_number ); ( "integer pattern constants agree with Lambda" >:: fun _ -> List.iter (fun (literal, expected) -> diff --git a/tests/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); 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/as_constructor_name_test.mjs b/tests/tests/src/as_constructor_name_test.mjs new file mode 100644 index 00000000000..74c585a1129 --- /dev/null +++ b/tests/tests/src/as_constructor_name_test.mjs @@ -0,0 +1,41 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + +import * as Mocha from "mocha"; +import * as Test_utils from "./test_utils.mjs"; + +let Stated = { + a: "A" +}; + +function isOne(x) { + return x === 1.0; +} + +function isOneInt(x) { + return x === 1; +} + +function isOneOf(x) { + return x.TAG === 1.0; +} + +Mocha.describe("As_constructor_name_test", () => { + Mocha.test("coercion", () => Test_utils.eq("File \"as_constructor_name_test.res\", line 50, characters 7-14", "A", "A")); + Mocha.test("folded matches of coerced constants", () => { + Test_utils.eq("File \"as_constructor_name_test.res\", line 54, characters 7-14", true, true); + Test_utils.eq("File \"as_constructor_name_test.res\", line 55, characters 7-14", true, true); + Test_utils.eq("File \"as_constructor_name_test.res\", line 56, characters 7-14", true, true); + }); + Mocha.test("interface", () => Test_utils.eq("File \"as_constructor_name_test.res\", line 60, characters 7-14", "A", "A")); +}); + +let declaredA = "A"; + +export { + declaredA, + Stated, + isOne, + isOneInt, + isOneOf, +} +/* Not a pure module */ diff --git a/tests/tests/src/as_constructor_name_test.res b/tests/tests/src/as_constructor_name_test.res new file mode 100644 index 00000000000..ff506e13143 --- /dev/null +++ b/tests/tests/src/as_constructor_name_test.res @@ -0,0 +1,62 @@ +open Mocha +open Test_utils + +// A constructor without @as is represented by its name, so `@as("A")` on a +// constructor named A states the same representation + +type named = A | B +type declared = | @as("A") A | B | C + +let declaredA = ((A: named) :> declared) + +module Stated: { + type t = A | B + let a: t +} = { + type t = | @as("A") A | B + let a = A +} + +// Literals are compared by runtime value, also when a match is folded +type sourceNumber = | @as(1.) One +type targetNumber = | @as(1.0) One | Two | Three | Four + +let isOne = (x: targetNumber) => + switch x { + | One => true + | _ => false + } + +type sourceInt = | @as(1) OneInt +type targetFloat = | @as(1.) OneInt | TwoInt | ThreeInt | FourInt + +let isOneInt = (x: targetFloat) => + switch x { + | OneInt => true + | _ => false + } + +type sourceBlock = | @as(1.) OneOf(int) +type targetBlock = | @as(1.0) OneOf(int) | TwoOf(int) + +let isOneOf = (x: targetBlock) => + switch x { + | OneOf(_) => true + | _ => false + } + +describe(__MODULE__, () => { + test("coercion", () => { + eq(__LOC__, declaredA, A) + }) + + test("folded matches of coerced constants", () => { + eq(__LOC__, isOne((One: sourceNumber) :> targetNumber), true) + eq(__LOC__, isOneOf((OneOf(1): sourceBlock) :> targetBlock), true) + eq(__LOC__, isOneInt((OneInt: sourceInt) :> targetFloat), true) + }) + + test("interface", () => { + eq(__LOC__, Stated.a, Stated.A) + }) +}) diff --git a/tests/tests/src/not_undefined_abbreviation_test.mjs b/tests/tests/src/not_undefined_abbreviation_test.mjs new file mode 100644 index 00000000000..56fb3dbe1ce --- /dev/null +++ b/tests/tests/src/not_undefined_abbreviation_test.mjs @@ -0,0 +1,46 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + +import * as Mocha from "mocha"; +import * as Test_utils from "./test_utils.mjs"; + +function kind(value) { + if (typeof value === "number") { + return "count"; + } else { + return value; + } +} + +function wrap(x) { + return x; +} + +function unwrap(x) { + if (x !== undefined) { + return "some"; + } else { + return "none"; + } +} + +let refinedValue = {}; + +Mocha.describe("Not_undefined_abbreviation_test", () => { + Mocha.test("a refined abstract type is not boxed in an option", () => { + Test_utils.eq("File \"not_undefined_abbreviation_test.res\", line 32, characters 7-14", refinedValue === refinedValue, true); + Test_utils.eq("File \"not_undefined_abbreviation_test.res\", line 33, characters 7-14", unwrap(refinedValue), "some"); + Test_utils.eq("File \"not_undefined_abbreviation_test.res\", line 34, characters 7-14", "none", "none"); + }); + Mocha.test("a restated builtin keeps its payload kind", () => { + Test_utils.eq("File \"not_undefined_abbreviation_test.res\", line 38, characters 7-14", "count", "count"); + Test_utils.eq("File \"not_undefined_abbreviation_test.res\", line 39, characters 7-14", "name", "name"); + }); +}); + +export { + kind, + wrap, + unwrap, + refinedValue, +} +/* Not a pure module */ diff --git a/tests/tests/src/not_undefined_abbreviation_test.res b/tests/tests/src/not_undefined_abbreviation_test.res new file mode 100644 index 00000000000..d9f978f1535 --- /dev/null +++ b/tests/tests/src/not_undefined_abbreviation_test.res @@ -0,0 +1,41 @@ +open Mocha +open Test_utils + +// @notUndefined on an abbreviation refines a type whose representation the +// compiler does not see, or restates that a type cannot be undefined + +type opaque +@notUndefined type refined = opaque + +@notUndefined type count = int + +@unboxed +type value = Count(count) | Name(string) + +let kind = value => + switch value { + | Count(_) => "count" + | Name(name) => name + } + +let wrap = (x: refined) => Some(x) +let unwrap = (x: option) => + switch x { + | Some(_) => "some" + | None => "none" + } + +let refinedValue: refined = %raw(`{}`) + +describe(__MODULE__, () => { + test("a refined abstract type is not boxed in an option", () => { + eq(__LOC__, Obj.magic(wrap(refinedValue)) === refinedValue, true) + eq(__LOC__, unwrap(wrap(refinedValue)), "some") + eq(__LOC__, unwrap(None), "none") + }) + + test("a restated builtin keeps its payload kind", () => { + eq(__LOC__, kind(Count(1)), "count") + eq(__LOC__, kind(Name("name")), "name") + }) +}) diff --git a/tests/tests/src/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..3f6e07e1bd0 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"; } @@ -57,13 +55,19 @@ function answerName(v) { } } +function answerName2(v) { + if (v === true) { + return "yes"; + } else { + return "answer false"; + } +} + 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 +152,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; } @@ -175,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"); }); }); @@ -273,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") diff --git a/tests/tests/src/untagged_builtin_alias_test.mjs b/tests/tests/src/untagged_builtin_alias_test.mjs index fbaf95ceb5b..686d8700f09 100644 --- a/tests/tests/src/untagged_builtin_alias_test.mjs +++ b/tests/tests/src/untagged_builtin_alias_test.mjs @@ -4,28 +4,62 @@ 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"; + } else { + return "entries"; } - switch (typeof value) { - case "object" : - return "entries"; - case "string" : - return value; +} + +function make(x) { + return x; +} + +let Score = { + make: make +}; + +function countedKind(value) { + if (typeof value === "number") { + return "number"; + } else { + return value; + } +} + +function scoredKind(value) { + if (typeof value === "number") { + return "number"; + } else { + return value; } } Mocha.describe("Untagged_builtin_alias_test", () => { Mocha.test("aliases of builtin types", () => { - Test_utils.eq("File \"untagged_builtin_alias_test.res\", line 21, characters 7-14", "entries", kind({ + Test_utils.eq("File \"untagged_builtin_alias_test.res\", line 51, characters 7-14", "entries", kind({ a: 1 })); - Test_utils.eq("File \"untagged_builtin_alias_test.res\", line 22, characters 7-14", "text", "text"); - Test_utils.eq("File \"untagged_builtin_alias_test.res\", line 23, characters 7-14", "pair", "pair"); + Test_utils.eq("File \"untagged_builtin_alias_test.res\", line 52, characters 7-14", "text", "text"); + Test_utils.eq("File \"untagged_builtin_alias_test.res\", line 53, characters 7-14", "pair", "pair"); + }); + Mocha.test("annotations stating a builtin type's kind", () => { + Test_utils.eq("File \"untagged_builtin_alias_test.res\", line 57, characters 7-14", "number", "number"); + Test_utils.eq("File \"untagged_builtin_alias_test.res\", line 58, characters 7-14", "name", "name"); + Test_utils.eq("File \"untagged_builtin_alias_test.res\", line 59, characters 7-14", "number", "number"); + Test_utils.eq("File \"untagged_builtin_alias_test.res\", line 60, characters 7-14", "name", "name"); }); }); +let Score$make = make; + export { kind, + Score, + countedKind, + scoredKind, + Score$make, } /* Not a pure module */ diff --git a/tests/tests/src/untagged_builtin_alias_test.res b/tests/tests/src/untagged_builtin_alias_test.res index d5de5e80ee2..3548fac2963 100644 --- a/tests/tests/src/untagged_builtin_alias_test.res +++ b/tests/tests/src/untagged_builtin_alias_test.res @@ -16,10 +16,47 @@ let kind = value => | Pair(_) => "pair" } +// An annotation can restate what a builtin type is recognized by, and an +// interface can state it over a builtin implementation +@typeOf("number") type count = int + +module Score: { + @typeOf("number") type t + let make: int => t +} = { + type t = int + let make = x => x +} + +@unboxed +type counted = Count(count) | CountName(string) + +let countedKind = value => + switch value { + | Count(_) => "number" + | CountName(name) => name + } + +@unboxed +type scored = Score(Score.t) | ScoreName(string) + +let scoredKind = value => + switch value { + | Score(_) => "number" + | ScoreName(name) => name + } + describe(__MODULE__, () => { test("aliases of builtin types", () => { eq(__LOC__, "entries", kind(Entries(dict{"a": 1}))) eq(__LOC__, "text", kind(Label("text"))) eq(__LOC__, "pair", kind(Pair((1, 2)))) }) + + test("annotations stating a builtin type's kind", () => { + eq(__LOC__, "number", countedKind(Count(1))) + eq(__LOC__, "name", countedKind(CountName("name"))) + eq(__LOC__, "number", scoredKind(Score(Score.make(2)))) + eq(__LOC__, "name", scoredKind(ScoreName("name"))) + }) }) diff --git a/tests/tests/src/untagged_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..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" @@ -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..4c4bfbd2c8a 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); @@ -368,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 e0068d02f5d..a806547fcfc 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", () => { @@ -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") diff --git a/tests/tests/src/variantsMatching.mjs b/tests/tests/src/variantsMatching.mjs index a23fbd46a8b..5d45bd1d348 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,36 +268,33 @@ 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 (y) { + switch (x) { case null : case undefined : - return x; + return y; case "WhyNotAnotherOne" : - return "WhyNotAnotherOne"; + break; + default: + switch (y) { + case null : + case undefined : + case "WhyNotAnotherOne" : + break; + default: + return { + x: x.x + y.x, + y: x.y + y.y + }; + } + } + if (y == null) { + return x; + } else { + return "WhyNotAnotherOne"; } } function kind$1(x) { - if (x !== null && x !== "WhyNotAnotherOne" && x !== undefined) { - return "present"; - } switch (x) { case null : return "null"; @@ -307,6 +302,8 @@ function kind$1(x) { return "undefined"; case "WhyNotAnotherOne" : return "whynot"; + default: + return "present"; } } @@ -388,7 +385,7 @@ function classify(x) { } else { return "boolean"; } - case "object" : + default: return "Object" + x.name; } }