coerce variants to string/int

Author: zth

Diff for: jscomp/build_tests/super_errors/expected/variant_coercion_int.res.expected

@@ -0,0 +1,10 @@
+
+  We've found a bug for you!
+  /.../fixtures/variant_coercion_int.res:5:10-17
+
+  3 │ let x = One(true)
+  4 │ 
+  5 │ let y = (x :> int)
+  6 │ 
+
+  Type x is not a subtype of int

Diff for: jscomp/build_tests/super_errors/expected/variant_coercion_int_as.res.expected

@@ -0,0 +1,10 @@
+
+  We've found a bug for you!
+  /.../fixtures/variant_coercion_int_as.res:5:10-17
+
+  3 │ let x = One
+  4 │ 
+  5 │ let y = (x :> int)
+  6 │ 
+
+  Type x is not a subtype of int

Diff for: jscomp/build_tests/super_errors/expected/variant_coercion_string.res.expected

@@ -0,0 +1,10 @@
+
+  We've found a bug for you!
+  /.../fixtures/variant_coercion_string.res:5:10-20
+
+  3 │ let x = One(true)
+  4 │ 
+  5 │ let y = (x :> string)
+  6 │ 
+
+  Type x is not a subtype of string

Diff for: jscomp/build_tests/super_errors/expected/variant_coercion_string_as.res.expected

@@ -0,0 +1,10 @@
+
+  We've found a bug for you!
+  /.../fixtures/variant_coercion_string_as.res:5:10-20
+
+  3 │ let x = One
+  4 │ 
+  5 │ let y = (x :> string)
+  6 │ 
+
+  Type x is not a subtype of string

Diff for: 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 for: 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 for: 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 for: 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 for: jscomp/ml/ctype.ml

@@ -3951,6 +3951,22 @@ 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(p, [], _)) when Path.same p Predef.path_string -> (* type coercion for variants represented by strings *)
+      (match extract_concrete_typedecl env t1 with
+      | (_, _, {type_kind=Type_variant (constructors)}) ->
+        if Variant_coercion.can_coerce_to_string constructors then
+          cstrs
+        else
+          (trace, t1, t2, !univar_pairs)::cstrs
+      | _ -> (trace, t1, t2, !univar_pairs)::cstrs)
+    | (Tconstr(_, [], _), Tconstr(p, [], _)) when Path.same p Predef.path_int -> (* type coercion for variants represented by ints *)
+      (match extract_concrete_typedecl env t1 with
+      | (_, _, {type_kind=Type_variant (constructors)}) ->
+        if Variant_coercion.can_coerce_to_int constructors then
+          cstrs
+        else
+          (trace, t1, t2, !univar_pairs)::cstrs
+      | _ -> (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 for: jscomp/ml/variant_coercion.ml

@@ -0,0 +1,34 @@
+
+type variant_representation = String | Int | Other
+
+let find_as_attribute_payload (attributes : Parsetree.attribute list) =
+  attributes
+  |> List.find_map (fun (({txt = name}, payload) : Parsetree.attribute) ->
+         match (name, payload) with
+         | ( "as",
+             PStr
+               [
+                 {
+                   pstr_desc =
+                     Pstr_eval ({pexp_desc = Pexp_constant constant}, _);
+                 };
+               ] ) ->
+           Some constant
+         | _ -> None)
+
+let constructors_representations
+    (constructors : Types.constructor_declaration list) =
+  constructors
+  |> List.map (fun (c : Types.constructor_declaration) ->
+         match (c.cd_args, c.cd_attributes |> find_as_attribute_payload) with
+         | Cstr_tuple [], (Some (Pconst_string _) | None) -> String
+         | Cstr_tuple [], Some (Pconst_integer _) -> Int
+         | _ -> Other)
+
+(* TODO: Improve error messages? Say why we can't coerce. *)
+
+let can_coerce_to_string (constructors : Types.constructor_declaration list) =
+  constructors |> constructors_representations |> List.for_all (( = ) String)
+
+let can_coerce_to_int (constructors : Types.constructor_declaration list) =
+  constructors |> constructors_representations |> List.for_all (( = ) Int)

Diff for: jscomp/test/VariantCoercion.js

@@ -0,0 +1,11 @@
+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)