Compare variant literals by their JavaScript value

changes/as-literals-by-value.fix.md

@@ -0,0 +1 @@
+- Reject `@as` literals of one variant that are the same JavaScript value, such as `@as(1)` and `@as(1.0)`, and accept `@as(1)` beside `@as(1n)`.

compiler/ml/UntaggedVariants.md

@@ -149,10 +149,15 @@ The type checker rejects an untagged variant, with
 | an unknown case beside another case with a payload | Case A has a payload that is not of one of the recognized shapes ... | `UntaggedOnlyOneUnknown.res`, `UntaggedUnknown.res` |
 | a `bool` case when both `true` and `false` are literal cases | Case B can never match ... | `UntaggedUnreachableBoolean.res` |
 | two nullary cases with the same literal | Duplicate literal x. | `UntaggedDuplicateLiteral.res` |
+| two nullary cases whose literals are spelled differently but are the same JavaScript value | The literal 1.0 is the same JavaScript value as 1. | `untagged_literal_same_number.res`, `untagged_literal_same_int32.res`, `untagged_literal_same_bigint.res` |
 
 Literals are compared per kind: string literals with each other (a case
 without `@as` counts as its name), and all other literals with each other by
-their spelling. The duplicate-literal check applies to every variant, tagged
+the JavaScript value they denote, as the `===` of a `switch` compares them.
+An int is the 32-bit number it is emitted as (rule 3), so `1`, `1.0` and
+`4294967297` are one number, and so are `0` and `-0.`; `1n` is a bigint and
+differs from `1`, and `001n` is `1n`. Constant folding (rule 11) compares
+literals the same way. The duplicate-literal check applies to every variant, tagged
 or not; in a tagged variant it also compares the `@as` tags of the cases with
 a payload.
 
@@ -161,10 +166,12 @@ 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`.
-- Tests: the fixtures above; `TaggedDuplicateLiteral.res`,
+- Implementation: `ast_untagged_variants.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`,
   `multiple_tag_1.res`, `multiple_tag_2.res` (tagged variants).
-- Shaped by #6128, #6136, #7441, #8777.
+- Shaped by #6128, #6136, #7441, #8777, #8953.
 
 ### 7. Literal cases are tested first
 
@@ -349,21 +356,6 @@ cases with a payload (see Known bugs).
 Each was observed with the compiler built from this tree; the programs are
 compiled with `bsc` and run in Node 25.
 
-**Numeric literals are compared by spelling.** Rule 6 compares `1` and `1.0`,
-and `1` and `4294967297`, as different literals, while they are one
-JavaScript number.
-
-```rescript
-@unboxed type t = | @as(1) A | @as(1.0) B
-let name = v => switch v { | A => "A" | B => "B" }
-@inline(never) let id = x => x
-Console.log2(name(B), name(id(B)))   // B A
-```
-
-The declaration is accepted; `B` is `1` at run time and matches as `A`, while
-the folded `name(B)` returns `"B"`. With `@as(4294967297) B`, `name(id(B))`
-returns `"A"` as well.
-
 **`Some` of a constant `undefined` case is `None`.** Rule 12 boxes `Some(v)`
 for a variant with an `@as(undefined)` case, but a constant argument skips
 the boxing.

compiler/ml/ast_untagged_variants.ml

@@ -11,6 +11,7 @@ type untagged_error =
   | AtMostOneBoolean
   | UnreachableBoolean of string
   | DuplicateLiteral of string
+  | SameLiteralValue of string * string
   | ConstructorMoreThanOneArg of string
 type error =
   | InvalidVariantAsAnnotation
@@ -59,6 +60,9 @@ let report_error ppf =
         "At most one case can be a number type (int or float)."
       | AtMostOneBigint -> "At most one case can be a bigint type."
       | DuplicateLiteral s -> "Duplicate literal " ^ s ^ "."
+      | SameLiteralValue (literal, earlier) ->
+        "The literal " ^ literal ^ " is the same JavaScript value as " ^ earlier
+        ^ "."
       | ConstructorMoreThanOneArg name ->
         "Constructor " ^ name ^ " has more than one argument.")
   | TagFieldNameConflict (constructor_name, field_name, runtime_value) ->
@@ -210,13 +214,18 @@ 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
-  let nonstring_literals_consts = ref String_set.empty in
-  let nonstring_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
@@ -233,13 +242,21 @@ let check_invariant ~is_untagged_def ~(consts : (Location.t * tag) list)
       raise (Error (loc, InvalidUntaggedVariantDefinition (DuplicateLiteral s)));
     set := String_set.add s !set
   in
-  let add_nonstring_literal ~is_const ~loc s =
-    let set =
+  let add_nonstring_literal ~is_const ~loc literal s =
+    let map =
       if is_const then nonstring_literals_consts else nonstring_literals_blocks
     in
-    if String_set.mem s !set then
-      raise (Error (loc, InvalidUntaggedVariantDefinition (DuplicateLiteral s)));
-    set := String_set.add s !set
+    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
@@ -269,13 +286,19 @@ let check_invariant ~is_untagged_def ~(consts : (Location.t * tag) list)
     match tag.literal with
     | None -> add_string_literal ~is_const ~loc tag.name
     | Some (String s) -> add_string_literal ~is_const ~loc s
-    | Some (Int i) -> add_nonstring_literal ~is_const ~loc (string_of_int i)
-    | Some (Float f) -> add_nonstring_literal ~is_const ~loc f
-    | Some (BigInt i) -> add_nonstring_literal ~is_const ~loc i
-    | Some (Bool b) ->
-      add_nonstring_literal ~is_const ~loc (if b then "true" else "false")
-    | Some Null -> add_nonstring_literal ~is_const ~loc "null"
-    | Some Undefined -> add_nonstring_literal ~is_const ~loc "undefined"
+    | 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) ->
@@ -300,8 +323,8 @@ let check_invariant ~is_untagged_def ~(consts : (Location.t * tag) list)
                payload only receives the booleans that are not literal cases.
                A partial overlap is allowed, like for strings and numbers. *)
             if
-              String_set.mem "true" !nonstring_literals_consts
-              && String_set.mem "false" !nonstring_literals_consts
+              String_map.mem "true" !nonstring_literals_consts
+              && String_map.mem "false" !nonstring_literals_consts
             then
               raise
                 (Error

compiler/ml/lambda.ml

@@ -841,18 +841,7 @@ let runtime_value_kind (c : structured_constant) =
    [1.0] are the same JavaScript number. Bigint spellings are not compared;
    both bigint payloads and bigint constructors are classified as unknown.
    Integer tags are emitted through [Int32.of_int], just like [Const_int]. *)
-let literal_denotes_same (a : Variant_runtime.literal_tag)
-    (b : Variant_runtime.literal_tag) =
-  match (a, b) with
-  | String x, String y -> x = y
-  | Int x, Int y -> Int32.of_int x = Int32.of_int y
-  | Float x, Float y -> float_of_string x = float_of_string y
-  | Int x, Float y | Float y, Int x ->
-    Int32.to_float (Int32.of_int x) = float_of_string y
-  | Bool x, Bool y -> x = y
-  | Null, Null | Undefined, Undefined -> true
-  | (String _ | Int _ | Float _ | Bool _ | BigInt _ | Null | Undefined), _ ->
-    false
+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. *)

compiler/ml/variant_runtime.ml

@@ -79,6 +79,25 @@ type literal_tag =
   | Null
   | Undefined
 
+(* [-0.] and [0.] are equal for [===]; [%h] is exact for every other number *)
+let number_key x = "number:" ^ if x = 0. then "0" else Printf.sprintf "%h" x
+
+let literal_value_key = function
+  | Int i -> number_key (Int32.to_float (Int32.of_int i))
+  | Float f -> (
+    match float_of_string_opt f with
+    | Some x -> number_key x
+    | None -> "number:" ^ f)
+  | BigInt i ->
+    let positive, digits = Bigint_utils.parse_bigint i in
+    "bigint:" ^ Bigint_utils.to_string (positive || digits = "0") digits
+  | Bool b -> if b then "true" else "false"
+  | Null -> "null"
+  | Undefined -> "undefined"
+  | String s -> "string:" ^ s
+
+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. *)

compiler/ml/variant_runtime.mli

@@ -50,6 +50,13 @@ type literal_tag =
   | Null
   | Undefined
 
+val literal_value_key : literal_tag -> string
+(** A key that two literals share exactly when they are the same JavaScript
+    value, as [===] compares them: ints are emitted as 32-bit numbers, so
+    [1], [1.0] and [4294967297] share one, while [1n] is a bigint. *)
+
+val same_literal_value : literal_tag -> literal_tag -> bool
+
 (** 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. *)

tests/build_tests/super_errors/expected/untagged_literal_same_bigint.res.expected

@@ -0,0 +1,8 @@
+
+  We've found a bug for you!
+  /.../fixtures/untagged_literal_same_bigint.res:1:31-43
+
+  1 │ @unboxed type t = | @as(1n) A | @as(001n) B
+  2 │ 
+
+  This untagged variant definition is invalid: The literal 001n is the same JavaScript value as 1n.

tests/build_tests/super_errors/expected/untagged_literal_same_int32.res.expected

@@ -0,0 +1,8 @@
+
+  We've found a bug for you!
+  /.../fixtures/untagged_literal_same_int32.res:1:30-48
+
+  1 │ @unboxed type t = | @as(1) A | @as(4294967297) B
+  2 │ 
+
+  This untagged variant definition is invalid: The literal 4294967297 is the same JavaScript value as 1.

tests/build_tests/super_errors/expected/untagged_literal_same_number.res.expected

@@ -0,0 +1,8 @@
+
+  We've found a bug for you!
+  /.../fixtures/untagged_literal_same_number.res:1:30-41
+
+  1 │ @unboxed type t = | @as(1) A | @as(1.0) B
+  2 │ 
+
+  This untagged variant definition is invalid: The literal 1.0 is the same JavaScript value as 1.

tests/build_tests/super_errors/fixtures/untagged_literal_same_bigint.res

@@ -0,0 +1 @@
+@unboxed type t = | @as(1n) A | @as(001n) B

tests/build_tests/super_errors/fixtures/untagged_literal_same_int32.res

@@ -0,0 +1 @@
+@unboxed type t = | @as(1) A | @as(4294967297) B

tests/build_tests/super_errors/fixtures/untagged_literal_same_number.res

@@ -0,0 +1 @@
+@unboxed type t = | @as(1) A | @as(1.0) B