Exploring variant-to-variant coercion (#6314)

zth · web-flow · commit 60cf75afa118 · 2023-06-29T20:04:39.000+02:00
* sketch out variant-to-variant coercion

* reuse logic from ast_untagged_variants

* reuse more logic

* handle inline records in variant coercion

* fix false positive in variant to primitive branch, and add tests

* changelog

* format

* reuse more logic from ast_untagged

* remove unused
diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -11,6 +11,8 @@
 > - :nail_care: [Polish]
 
 # 11.0.0-beta.4 (Unreleased)
+#### :rocket: New Feature
+- Variants: Allow coercing from variant to variant, where applicable. https://github.com/rescript-lang/rescript-compiler/pull/6314
 
 # 11.0.0-beta.3
 
diff --git a/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion.res.expected b/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion.res.expected
@@ -0,0 +1,10 @@
+
+  [1;31mWe've found a bug for you![0m
+  [36m/.../fixtures/variant_to_variant_coercion.res[0m:[2m6:10-15[0m
+
+  4 [2m│[0m let x: x = One(true)
+  5 [2m│[0m 
+  [1;31m6[0m [2m│[0m let y = ([1;31mx :> y[0m)
+  7 [2m│[0m 
+
+  Type x is not a subtype of y
diff --git a/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion_as.res.expected b/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion_as.res.expected
@@ -0,0 +1,10 @@
+
+  [1;31mWe've found a bug for you![0m
+  [36m/.../fixtures/variant_to_variant_coercion_as.res[0m:[2m6:10-15[0m
+
+  4 [2m│[0m let x: x = One(true)
+  5 [2m│[0m 
+  [1;31m6[0m [2m│[0m let y = ([1;31mx :> y[0m)
+  7 [2m│[0m 
+
+  Type x is not a subtype of y
diff --git a/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion_tag.res.expected b/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion_tag.res.expected
@@ -0,0 +1,10 @@
+
+  [1;31mWe've found a bug for you![0m
+  [36m/.../fixtures/variant_to_variant_coercion_tag.res[0m:[2m6:10-15[0m
+
+  4 [2m│[0m let x: x = One(true)
+  5 [2m│[0m 
+  [1;31m6[0m [2m│[0m let y = ([1;31mx :> y[0m)
+  7 [2m│[0m 
+
+  Type x is not a subtype of y
diff --git a/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion_unboxed.res.expected b/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion_unboxed.res.expected
@@ -0,0 +1,10 @@
+
+  [1;31mWe've found a bug for you![0m
+  [36m/.../fixtures/variant_to_variant_coercion_unboxed.res[0m:[2m6:10-15[0m
+
+  4 [2m│[0m let x: x = One(true)
+  5 [2m│[0m 
+  [1;31m6[0m [2m│[0m let y = ([1;31mx :> y[0m)
+  7 [2m│[0m 
+
+  Type x is not a subtype of y
diff --git a/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion.res b/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion.res
@@ -0,0 +1,6 @@
+type x = One(bool) | Two
+type y = One(string) | Two
+
+let x: x = One(true)
+
+let y = (x :> y)
diff --git a/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion_as.res b/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion_as.res
@@ -0,0 +1,6 @@
+type x = | @as("one") One(bool) | Two(string)
+type y = One(bool) | Two(string)
+
+let x: x = One(true)
+
+let y = (x :> y)
diff --git a/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion_tag.res b/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion_tag.res
@@ -0,0 +1,6 @@
+@tag("kind") type x = One(bool) | Two(string)
+type y = One(bool) | Two(string)
+
+let x: x = One(true)
+
+let y = (x :> y)
diff --git a/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion_unboxed.res b/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion_unboxed.res
@@ -0,0 +1,6 @@
+@unboxed type x = One(bool) | Two
+type y = One(bool) | Two
+
+let x: x = One(true)
+
+let y = (x :> y)
diff --git a/jscomp/core/matching_polyfill.ml b/jscomp/core/matching_polyfill.ml
@@ -22,6 +22,8 @@
  * along with this program; if not, write to the Free Software
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
+let () = Ast_untagged_variants.extract_concrete_typedecl := Ctype.extract_concrete_typedecl
+
 let names_from_construct_pattern (pat : Typedtree.pattern) =
   let rec resolve_path n (path : Path.t) =
     match Env.find_type path pat.pat_env with
diff --git a/jscomp/ml/ast_uncurried.ml b/jscomp/ml/ast_uncurried.ml
@@ -69,12 +69,7 @@ let coreTypeIsUncurriedFun (typ : Parsetree.core_type) =
     true
   | _ -> false
 
-let typeIsUncurriedFun (typ : Types.type_expr) =
-  match typ.desc with
-  | Tconstr (Pident {name = "function$"}, [{desc = Tarrow _}; _], _) ->
-    true
-  | _ -> false
-
+let typeIsUncurriedFun = Ast_uncurried_utils.typeIsUncurriedFun
 
 let typeExtractUncurriedFun (typ : Parsetree.core_type) =
   match typ.ptyp_desc with
diff --git a/jscomp/ml/ast_uncurried_utils.ml b/jscomp/ml/ast_uncurried_utils.ml
@@ -0,0 +1,5 @@
+let typeIsUncurriedFun (typ : Types.type_expr) =
+  match typ.desc with
+  | Tconstr (Pident {name = "function$"}, [{desc = Tarrow _}; _], _) ->
+    true
+  | _ -> false
diff --git a/jscomp/ml/ast_untagged_variants.ml b/jscomp/ml/ast_untagged_variants.ml
@@ -77,6 +77,10 @@ let process_untagged (attrs : Parsetree.attributes) =
       | _ -> ());
   !st
 
+let extract_concrete_typedecl: (Env.t ->
+  Types.type_expr ->
+  Path.t * Path.t * Types.type_declaration) ref = ref (Obj.magic ())
+
 let process_tag_type (attrs : Parsetree.attributes) =
   let st : tag_type option ref = ref None in
   Ext_list.iter attrs (fun ({txt; loc}, payload) ->
@@ -137,7 +141,7 @@ let get_block_type ~env (cstr : Types.constructor_declaration) :
     when Path.same path Predef.path_array ->
     Some ArrayType
   | true, Cstr_tuple [({desc = Tconstr _} as t)]
-    when Ast_uncurried.typeIsUncurriedFun t ->
+    when Ast_uncurried_utils.typeIsUncurriedFun t ->
     Some FunctionType
   | true, Cstr_tuple [{desc = Tarrow _}] -> Some FunctionType
   | true, Cstr_tuple [{desc = Tconstr (path, _, _)}]
@@ -148,7 +152,7 @@ let get_block_type ~env (cstr : Types.constructor_declaration) :
     Some ObjectType
   | true, Cstr_tuple [ty] -> (
     let default = Some UnknownType in
-    match Ctype.extract_concrete_typedecl env ty with
+    match !extract_concrete_typedecl env ty with
     | _, _, {type_kind = Type_record (_, Record_unboxed _)} -> default
     | _, _, {type_kind = Type_record (_, _)} -> Some ObjectType
     | _ -> default
diff --git a/jscomp/ml/ctype.ml b/jscomp/ml/ctype.ml
@@ -3952,18 +3952,55 @@ let rec subtype_rec env trace t1 t2 cstrs =
     | (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
+        extract_concrete_typedecl env t1 |> Variant_coercion.can_try_coerce_variant_to_primitive |> Option.is_some
+        ->
+      (* type coercion for variants to primitives *)
+      (match Variant_coercion.can_try_coerce_variant_to_primitive (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 *)
+    | (Tconstr(_, [], _), Tconstr(_, [], _)) -> (* type coercion for variants and records *)
       (match extract_concrete_typedecl env t1, extract_concrete_typedecl env t2 with
+      | (_, _, {type_kind=Type_variant (c1); type_attributes=t1attrs}), (_, _, {type_kind=Type_variant (c2); type_attributes=t2attrs}) ->
+        if 
+          Variant_coercion.variant_configuration_can_be_coerced t1attrs t2attrs = false 
+        then 
+          (trace, t1, t2, !univar_pairs)::cstrs 
+        else
+          let c1_len = List.length c1 in
+          if c1_len > List.length c2 then (trace, t1, t2, !univar_pairs)::cstrs
+          else
+            let constructor_map = Hashtbl.create c1_len in
+            c2
+            |> List.iter (fun (c : Types.constructor_declaration) ->
+                  Hashtbl.add constructor_map (Ident.name c.cd_id) c);
+            if c1 |> List.for_all (fun (c : Types.constructor_declaration) ->
+                  match (c, Hashtbl.find_opt constructor_map (Ident.name c.cd_id)) with
+                  | ( {Types.cd_args = Cstr_record fields1; cd_attributes=c1_attributes},
+                      Some {Types.cd_args = Cstr_record fields2; cd_attributes=c2_attributes} ) ->
+                      if Variant_coercion.variant_representation_matches c1_attributes c2_attributes then
+                        let violation, tl1, tl2 = Record_coercion.check_record_fields fields1 fields2 in
+                        if violation then false
+                        else
+                          begin try
+                            let lst = subtype_list env trace tl1 tl2 cstrs in
+                            List.length lst = List.length cstrs
+                          with | _ -> false end
+                      else false
+                  | ( {Types.cd_args = Cstr_tuple tl1; cd_attributes=c1_attributes},
+                      Some {Types.cd_args = Cstr_tuple tl2; cd_attributes=c2_attributes} ) ->
+                      if Variant_coercion.variant_representation_matches c1_attributes c2_attributes then
+                        begin try
+                          let lst = subtype_list env trace tl1 tl2 cstrs in
+                          List.length lst = List.length cstrs
+                        with | _ -> false end
+                      else false
+                  | _ -> false)
+            then cstrs
+            else (trace, t1, t2, !univar_pairs)::cstrs
       | (_, _, {type_kind=Type_record (fields1, repr1)}), (_, _, {type_kind=Type_record (fields2, repr2)}) ->
         let same_repr = match repr1, repr2 with
           | (Record_regular | Record_optional_labels _), (Record_regular | Record_optional_labels _) ->
@@ -3973,30 +4010,8 @@ let rec subtype_rec env trace t1 t2 cstrs =
           | Record_extension, Record_extension -> true
           | _ -> false in
         if same_repr then
-          let field_is_optional id repr = match repr with
-            | Record_optional_labels lbls -> List.mem (Ident.name id) lbls
-            | _ -> false in
-          let violation = ref false in
-          let label_decl_sub (acc1, acc2) ld2 =
-            match Ext_list.find_first fields1 (fun ld1 -> ld1.ld_id.name = ld2.ld_id.name) with
-            | Some ld1 ->
-              if field_is_optional ld1.ld_id repr1 <> (field_is_optional ld2.ld_id repr2) then
-                (* optional field can't be modified *)
-                violation := true;
-              let get_as (({txt}, payload) : Parsetree.attribute) =
-                if txt = "as" then Ast_payload.is_single_string payload
-                else None in
-              let get_as_name ld = match Ext_list.filter_map ld.ld_attributes get_as with
-                | [] -> ld.ld_id.name
-                | (s,_)::_ -> s in
-              if get_as_name ld1 <> get_as_name ld2 then violation := true;
-              ld1.ld_type :: acc1, ld2.ld_type :: acc2
-            | None ->
-              (* field must be present *)
-              violation := true;
-              (acc1, acc2) in
-          let tl1, tl2 = List.fold_left label_decl_sub ([], []) fields2 in
-          if !violation
+          let violation, tl1, tl2 = Record_coercion.check_record_fields ~repr1 ~repr2 fields1 fields2 in
+          if violation
           then (trace, t1, t2, !univar_pairs)::cstrs
           else
             subtype_list env trace tl1 tl2 cstrs
diff --git a/jscomp/ml/record_coercion.ml b/jscomp/ml/record_coercion.ml
@@ -0,0 +1,33 @@
+let check_record_fields ?repr1 ?repr2 (fields1 : Types.label_declaration list)
+    (fields2 : Types.label_declaration list) =
+  let field_is_optional id repr =
+    match repr with
+    | Some (Types.Record_optional_labels lbls) -> List.mem (Ident.name id) lbls
+    | _ -> false
+  in
+  let violation = ref false in
+  let label_decl_sub (acc1, acc2) (ld2 : Types.label_declaration) =
+    match
+      Ext_list.find_first fields1 (fun ld1 -> ld1.ld_id.name = ld2.ld_id.name)
+    with
+    | Some ld1 ->
+      if field_is_optional ld1.ld_id repr1 <> field_is_optional ld2.ld_id repr2
+      then (* optional field can't be modified *)
+        violation := true;
+      let get_as (({txt}, payload) : Parsetree.attribute) =
+        if txt = "as" then Ast_payload.is_single_string payload else None
+      in
+      let get_as_name (ld : Types.label_declaration) =
+        match Ext_list.filter_map ld.ld_attributes get_as with
+        | [] -> ld.ld_id.name
+        | (s, _) :: _ -> s
+      in
+      if get_as_name ld1 <> get_as_name ld2 then violation := true;
+      (ld1.ld_type :: acc1, ld2.ld_type :: acc2)
+    | None ->
+      (* field must be present *)
+      violation := true;
+      (acc1, acc2)
+  in
+  let tl1, tl2 = List.fold_left label_decl_sub ([], []) fields2 in
+  (!violation, tl1, tl2)
diff --git a/jscomp/ml/variant_coercion.ml b/jscomp/ml/variant_coercion.ml
@@ -1,61 +1,64 @@
-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)
-
+(* Right now we only allow coercing to primitives string/int/float *)
 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
+  constructors
+  |> List.for_all (fun (c : Types.constructor_declaration) ->
+         let args = c.cd_args in
+         let payload = Ast_untagged_variants.process_tag_type c.cd_attributes in
+         match args with
+         | Cstr_tuple [] -> (
+           match payload with
+           | None | Some (String _) -> Path.same path Predef.path_string
+           | Some (Int _) -> Path.same path Predef.path_int
+           | Some (Float _) -> Path.same path Predef.path_float
+           | Some (Null | Undefined | Bool _ | Untagged _) -> false)
+         | _ -> false)
 
-let is_variant_typedecl
-    ((_, _, typedecl) : Path.t * Path.t * Types.type_declaration) =
+let can_try_coerce_variant_to_primitive
+    ((_, p, typedecl) : Path.t * Path.t * Types.type_declaration) =
   match typedecl with
-  | {type_kind = Type_variant constructors} -> Some constructors
+  | {type_kind = Type_variant constructors; type_params = []}
+    when Path.name p <> "bool" ->
+    (* bool is represented as a variant internally, so we need to account for that *)
+    Some constructors
   | _ -> None
+
+let variant_representation_matches (c1_attrs : Parsetree.attributes)
+    (c2_attrs : Parsetree.attributes) =
+  match
+    ( Ast_untagged_variants.process_tag_type c1_attrs,
+      Ast_untagged_variants.process_tag_type c2_attrs )
+  with
+  | None, None -> true
+  | Some s1, Some s2 when s1 = s2 -> true
+  | _ -> false
+
+let variant_configuration_can_be_coerced (a1 : Parsetree.attributes)
+    (a2 : Parsetree.attributes) =
+  let unboxed =
+    match
+      ( Ast_untagged_variants.process_untagged a1,
+        Ast_untagged_variants.process_untagged a2 )
+    with
+    | true, true | false, false -> true
+    | _ -> false
+  in
+  if not unboxed then false
+  else
+    let tag =
+      match
+        ( Ast_untagged_variants.process_tag_name a1,
+          Ast_untagged_variants.process_tag_name a2 )
+      with
+      | Some tag1, Some tag2 when tag1 = tag2 -> true
+      | None, None -> true
+      | _ -> false
+    in
+    if not tag then false else true
diff --git a/jscomp/test/VariantCoercion.js b/jscomp/test/VariantCoercion.js
diff --git a/jscomp/test/VariantCoercion.res b/jscomp/test/VariantCoercion.res

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