Allow coercing elgible variants to string/int/float (#6311)

zth · web-flow · commit 8840a5fbe92b · 2023-06-27T13:41:34.000+02:00
* coerce variants to string/int

* coerce elgible variants to float

* reuse existing compiler logic for as attribute payloads

* extract match logic and bake variant matching into the same branch as record matching

* restructure guard for variant coercion

* format

* changelog and small cleanup
diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -16,6 +16,7 @@
 - Untagged variants: consider regexp as an object type. https://github.com/rescript-lang/rescript-compiler/pull/6296
 - Semantic-based optimization of code generated for untagged variants https://github.com/rescript-lang/rescript-compiler/issues/6108
 - Record type spreads: Allow using type variables in type spreads. Both uninstantiated and instantiated ones https://github.com/rescript-lang/rescript-compiler/pull/6309
+- Variants: Allow coercing variants to string/int/float when applicable https://github.com/rescript-lang/rescript-compiler/pull/6311
 
 #### :bug: Bug Fix
 - Fix issue where dynamic import of module in the expression https://github.com/rescript-lang/rescript-compiler/pull/6310
diff --git a/jscomp/build_tests/super_errors/expected/variant_coercion_float.res.expected b/jscomp/build_tests/super_errors/expected/variant_coercion_float.res.expected
@@ -0,0 +1,10 @@
+
+  [1;31mWe've found a bug for you![0m
+  [36m/.../fixtures/variant_coercion_float.res[0m:[2m5:10-19[0m
+
+  3 [2m│[0m let x = One(true)
+  4 [2m│[0m 
+  [1;31m5[0m [2m│[0m let y = ([1;31mx :> float[0m)
+  6 [2m│[0m 
+
+  Type x is not a subtype of float
diff --git a/jscomp/build_tests/super_errors/expected/variant_coercion_float_as.res.expected b/jscomp/build_tests/super_errors/expected/variant_coercion_float_as.res.expected
@@ -0,0 +1,10 @@
+
+  [1;31mWe've found a bug for you![0m
+  [36m/.../fixtures/variant_coercion_float_as.res[0m:[2m5:10-19[0m
+
+  3 [2m│[0m let x = One
+  4 [2m│[0m 
+  [1;31m5[0m [2m│[0m let y = ([1;31mx :> float[0m)
+  6 [2m│[0m 
+
+  Type x is not a subtype of float
diff --git a/jscomp/build_tests/super_errors/expected/variant_coercion_int.res.expected b/jscomp/build_tests/super_errors/expected/variant_coercion_int.res.expected
@@ -0,0 +1,10 @@
+
+  [1;31mWe've found a bug for you![0m
+  [36m/.../fixtures/variant_coercion_int.res[0m:[2m5:10-17[0m
+
+  3 [2m│[0m let x = One(true)
+  4 [2m│[0m 
+  [1;31m5[0m [2m│[0m let y = ([1;31mx :> int[0m)
+  6 [2m│[0m 
+
+  Type x is not a subtype of int
diff --git a/jscomp/build_tests/super_errors/expected/variant_coercion_int_as.res.expected b/jscomp/build_tests/super_errors/expected/variant_coercion_int_as.res.expected
@@ -0,0 +1,10 @@
+
+  [1;31mWe've found a bug for you![0m
+  [36m/.../fixtures/variant_coercion_int_as.res[0m:[2m5:10-17[0m
+
+  3 [2m│[0m let x = One
+  4 [2m│[0m 
+  [1;31m5[0m [2m│[0m let y = ([1;31mx :> int[0m)
+  6 [2m│[0m 
+
+  Type x is not a subtype of int
diff --git a/jscomp/build_tests/super_errors/expected/variant_coercion_string.res.expected b/jscomp/build_tests/super_errors/expected/variant_coercion_string.res.expected
@@ -0,0 +1,10 @@
+
+  [1;31mWe've found a bug for you![0m
+  [36m/.../fixtures/variant_coercion_string.res[0m:[2m5:10-20[0m
+
+  3 [2m│[0m let x = One(true)
+  4 [2m│[0m 
+  [1;31m5[0m [2m│[0m let y = ([1;31mx :> string[0m)
+  6 [2m│[0m 
+
+  Type x is not a subtype of string
diff --git a/jscomp/build_tests/super_errors/expected/variant_coercion_string_as.res.expected b/jscomp/build_tests/super_errors/expected/variant_coercion_string_as.res.expected
@@ -0,0 +1,10 @@
+
+  [1;31mWe've found a bug for you![0m
+  [36m/.../fixtures/variant_coercion_string_as.res[0m:[2m5:10-20[0m
+
+  3 [2m│[0m let x = One
+  4 [2m│[0m 
+  [1;31m5[0m [2m│[0m let y = ([1;31mx :> string[0m)
+  6 [2m│[0m 
+
+  Type x is not a subtype of string
diff --git a/jscomp/build_tests/super_errors/fixtures/variant_coercion_float.res b/jscomp/build_tests/super_errors/fixtures/variant_coercion_float.res
@@ -0,0 +1,5 @@
+type x = | @as(1.1) One(bool) | @as(2.2) Two
+
+let x = One(true)
+
+let y = (x :> float)
diff --git a/jscomp/build_tests/super_errors/fixtures/variant_coercion_float_as.res b/jscomp/build_tests/super_errors/fixtures/variant_coercion_float_as.res
@@ -0,0 +1,5 @@
+type x = | @as(1.1) One | Two
+
+let x = One
+
+let y = (x :> float)
diff --git a/jscomp/build_tests/super_errors/fixtures/variant_coercion_int.res b/jscomp/build_tests/super_errors/fixtures/variant_coercion_int.res
@@ -0,0 +1,5 @@
+type x = | @as(1) One(bool) | @as(2) Two
+
+let x = One(true)
+
+let y = (x :> int)
diff --git a/jscomp/build_tests/super_errors/fixtures/variant_coercion_int_as.res b/jscomp/build_tests/super_errors/fixtures/variant_coercion_int_as.res
@@ -0,0 +1,5 @@
+type x = | @as(1) One | Two
+
+let x = One
+
+let y = (x :> int)
diff --git a/jscomp/build_tests/super_errors/fixtures/variant_coercion_string.res b/jscomp/build_tests/super_errors/fixtures/variant_coercion_string.res
@@ -0,0 +1,5 @@
+type x = One(bool) | Two
+
+let x = One(true)
+
+let y = (x :> string)
diff --git a/jscomp/build_tests/super_errors/fixtures/variant_coercion_string_as.res b/jscomp/build_tests/super_errors/fixtures/variant_coercion_string_as.res
@@ -0,0 +1,5 @@
+type x = One | @as(2) Two
+
+let x = One
+
+let y = (x :> string)
diff --git a/jscomp/ml/ctype.ml b/jscomp/ml/ctype.ml
@@ -3951,6 +3951,17 @@ let rec subtype_rec env trace t1 t2 cstrs =
         end
     | (Tconstr(p1, _, _), _) when generic_private_abbrev env p1 ->
         subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs
+    | (Tconstr(_, [], _), Tconstr(path, [], _)) when Variant_coercion.can_coerce_path path && 
+        extract_concrete_typedecl env t1 |> Variant_coercion.is_variant_typedecl |> Option.is_some 
+        -> 
+      (* type coercion for variants *)
+      (match Variant_coercion.is_variant_typedecl (extract_concrete_typedecl env t1) with
+      | Some constructors -> 
+        if constructors |> Variant_coercion.can_coerce_variant ~path then
+          cstrs
+        else 
+          (trace, t1, t2, !univar_pairs)::cstrs
+      | None -> (trace, t1, t2, !univar_pairs)::cstrs)
     | (Tconstr(_, [], _), Tconstr(_, [], _)) -> (* type coercion for records *)
       (match extract_concrete_typedecl env t1, extract_concrete_typedecl env t2 with
       | (_, _, {type_kind=Type_record (fields1, repr1)}), (_, _, {type_kind=Type_record (fields2, repr2)}) ->
diff --git a/jscomp/ml/variant_coercion.ml b/jscomp/ml/variant_coercion.ml
@@ -0,0 +1,61 @@
+let find_as_attribute_payload (attributes : Parsetree.attribute list) =
+  attributes
+  |> List.find_map (fun (attr : Parsetree.attribute) ->
+         match attr with
+         | {txt = "as"}, payload -> Some payload
+         | _ -> None)
+
+(* TODO: Improve error messages? Say why we can't coerce. *)
+
+let check_constructors (constructors : Types.constructor_declaration list) check
+    =
+  List.for_all
+    (fun (c : Types.constructor_declaration) ->
+      check c.cd_args (find_as_attribute_payload c.cd_attributes))
+    constructors
+
+let can_coerce_to_string (constructors : Types.constructor_declaration list) =
+  check_constructors constructors (fun args payload ->
+      match (args, payload) with
+      | Cstr_tuple [], None -> true
+      | Cstr_tuple [], Some payload
+        when Ast_payload.is_single_string payload |> Option.is_some ->
+        true
+      | _ -> false)
+
+let can_coerce_to_int (constructors : Types.constructor_declaration list) =
+  check_constructors constructors (fun args payload ->
+      match (args, payload) with
+      | Cstr_tuple [], Some payload
+        when Ast_payload.is_single_int payload |> Option.is_some ->
+        true
+      | _ -> false)
+
+let can_coerce_to_float (constructors : Types.constructor_declaration list) =
+  check_constructors constructors (fun args payload ->
+      match (args, payload) with
+      | Cstr_tuple [], Some payload
+        when Ast_payload.is_single_float payload |> Option.is_some ->
+        true
+      | _ -> false)
+
+let can_coerce_path (path : Path.t) =
+  Path.same path Predef.path_string
+  || Path.same path Predef.path_int
+  || Path.same path Predef.path_float
+
+let can_coerce_variant ~(path : Path.t)
+    (constructors : Types.constructor_declaration list) =
+  if Path.same path Predef.path_string && can_coerce_to_string constructors then
+    true
+  else if Path.same path Predef.path_int && can_coerce_to_int constructors then
+    true
+  else if Path.same path Predef.path_float && can_coerce_to_float constructors
+  then true
+  else false
+
+let is_variant_typedecl
+    ((_, _, typedecl) : Path.t * Path.t * Types.type_declaration) =
+  match typedecl with
+  | {type_kind = Type_variant constructors} -> Some constructors
+  | _ -> None
diff --git a/jscomp/test/VariantCoercion.js b/jscomp/test/VariantCoercion.js
diff --git a/jscomp/test/VariantCoercion.res b/jscomp/test/VariantCoercion.res
@@ -0,0 +1,17 @@
+type a = One | @as("two") Two | Three
+
+let a: a = Three
+
+let b = (a :> string)
+
+type onlyInts = | @as(1) One1 | @as(2) Two2 | @as(3) Three3
+
+let i = One1
+
+let d = (i :> int)
+
+type onlyFloats = | @as(1.1) Onef | @as(2.2) Twof | @as(3.3) Threef
+
+let ii = Onef
+
+let dd = (ii :> float)
diff --git a/jscomp/test/build.ninja b/jscomp/test/build.ninja

-Original file line number
+Diff line change
@@ @@ -0,0 +1,10 @@ @@
++
 +  [1;31mWe've found a bug for you![0m
 +  [36m/.../fixtures/variant_coercion_float.res[0m:[2m5:10-19[0m
++
 +  3 [2m│[0m let x = One(true)
 +  4 [2m│[0m
 +  [1;31m5[0m [2m│[0m let y = ([1;31mx :> float[0m)
 +  6 [2m│[0m
++
 +  Type x is not a subtype of float