Allow free vars in types for coercion. (#6828)

* Test: allow free vars in types for coercion.

See #6821

Free variables are not allowed in coercion, and if that happens, simple unification is performed without ever attempting coercion. This seems to go back a very long time.

There's  probably a good reason why free vars were not allowed. At the same time, there are no objects/classes supported in the language anymore, so it's not clear how those reasons would adapt.

This just marks the place where one could investigate.

* Add tests of type coercion with free vars.

* Clean up code for coercion and free variables.

* Update CHANGELOG.md

* Remove unused code for self coercion.

* Remove unused error that suggests double coercion.

Author: cristianoc

CHANGELOG.md

@@ -17,6 +17,7 @@
 - Allow `@directive` on functions for emitting function level directive code (`let serverAction = @directive("'use server'") (~name) => {...}`). https://github.com/rescript-lang/rescript-compiler/pull/6756
 - Add `rewatch` to the npm package as an alternative build tool. https://github.com/rescript-lang/rescript-compiler/pull/6762
 - Throws an instance of JavaScript's `new Error()` and adds the extension payload for `cause` option. https://github.com/rescript-lang/rescript-compiler/pull/6611
+- Allow free vars in types for type coercion `e :> t`. https://github.com/rescript-lang/rescript-compiler/pull/6828
 
 #### :boom: Breaking Change
 

jscomp/ml/typecore.ml

@@ -46,8 +46,6 @@ type error =
   | Private_label of Longident.t * type_expr
 
   | Not_subtype of (type_expr * type_expr) list * (type_expr * type_expr) list
-  | Coercion_failure of
-      type_expr * type_expr * (type_expr * type_expr) list * bool
   | Too_many_arguments of bool * type_expr
   | Abstract_wrong_label of arg_label * type_expr
   | Scoping_let_module of string * type_expr
@@ -1783,9 +1781,6 @@ let generalizable level ty =
   try check ty; unmark_type ty; true
   with Exit -> unmark_type ty; false
 
-(* Hack to allow coercion of self. Will clean-up later. *)
-let self_coercion = ref ([] : (Path.t * Location.t list ref) list)
-
 (* Helpers for packaged modules. *)
 let create_package_type loc env (p, l) =
   let s = !Typetexp.transl_modtype_longident loc env p in
@@ -2592,31 +2587,20 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg=Rejected) env sexp ty
               gen
             end else true
           in
-          begin match arg.exp_desc, !self_coercion, (repr ty').desc with
-          | _ when free_variables ~env arg.exp_type = []
-                && free_variables ~env ty' = [] ->
-              if not gen && (* first try a single coercion *)
-                let snap = snapshot () in
-                let ty, _b = enlarge_type env ty' in
-                try
-                  force (); Ctype.unify env arg.exp_type ty; true
-                with Unify _ ->
-                  backtrack snap; false
-              then ()
-              else begin try
-                let force' = subtype env arg.exp_type ty' in
-                force (); force' ();
-              with Subtype (tr1, tr2) ->
-                (* prerr_endline "coercion failed"; *)
-                raise(Error(loc, env, Not_subtype(tr1, tr2)))
-              end;
-          | _ ->
-              let ty, b = enlarge_type env ty' in
-              force ();
-              begin try Ctype.unify env arg.exp_type ty with Unify trace ->
-                raise(Error(sarg.pexp_loc, env,
-                      Coercion_failure(ty', full_expand env ty', trace, b)))
-              end
+          if not gen && (* first try a single coercion *)
+            let snap = snapshot () in
+            let ty, _b = enlarge_type env ty' in
+            try
+              force (); Ctype.unify env arg.exp_type ty; true
+            with Unify _ ->
+              backtrack snap; false
+          then ()
+          else begin try
+            let force' = subtype env arg.exp_type ty' in
+            force (); force' ();
+          with Subtype (tr1, tr2) ->
+            (* prerr_endline "coercion failed"; *)
+            raise(Error(loc, env, Not_subtype(tr1, tr2)))
           end;
           (arg, ty', cty')
       in
@@ -3925,20 +3909,6 @@ let report_error env ppf = function
       end
   | Not_subtype(tr1, tr2) ->
       report_subtyping_error ppf env tr1 "is not a subtype of" tr2
-  | Coercion_failure (ty, ty', trace, b) ->
-    (* modified *)
-    super_report_unification_error ppf env trace
-      (function ppf ->
-         let ty, ty' = Printtyp.prepare_expansion (ty, ty') in
-         fprintf ppf
-           "This expression cannot be coerced to type@;<1 2>%a;@ it has type"
-           (Printtyp.type_expansion ty) ty')
-      (function ppf ->
-         fprintf ppf "but is here used with type");
-    if b then
-      fprintf ppf ".@.@[<hov>%s@ %s@]"
-        "This simple coercion was not fully general."
-        "Consider using a double coercion."
   | Too_many_arguments (in_function, ty) ->
     (* modified *)
     reset_and_mark_loops ty;

jscomp/ml/typecore.mli

@@ -58,8 +58,6 @@ val generalizable: int -> type_expr -> bool
 val id_of_pattern : Typedtree.pattern -> Ident.t option
 val name_pattern : string -> Typedtree.case list -> Ident.t
 
-val self_coercion : (Path.t * Location.t list ref) list ref
-
 type error =
     Polymorphic_label of Longident.t
   | Constructor_arity_mismatch of Longident.t * int * int
@@ -81,8 +79,6 @@ type error =
   | Private_type of type_expr
   | Private_label of Longident.t * type_expr
   | Not_subtype of (type_expr * type_expr) list * (type_expr * type_expr) list
-  | Coercion_failure of
-      type_expr * type_expr * (type_expr * type_expr) list * bool
   | Too_many_arguments of bool * type_expr
   | Abstract_wrong_label of arg_label * type_expr
   | Scoping_let_module of string * type_expr

jscomp/test/build.ninja

@@ -0,0 +1,38 @@
+module NoFreeVars = {
+  type t = private int
+
+  let f = (x: t) => (x :> int)
+
+  let g = (y: t) => ()
+
+  let h = x => (g(x), (x :> int))
+
+//  let h2 = x => ((x :> int), g(x))
+}
+
+module WithTypeArg = {
+  type t<'a> = private int
+
+  let f = (x: t<_>) => (x :> int)
+}
+
+module FunctionType = {
+  type t = private int
+  let f = _ => (Obj.magic(3) : t)
+  let _ = f :> (_ => int)
+}
+
+module Contravariant = {
+  type t = private int
+  let f1 = (_:int) => ()
+  let _ = f1 :> (t => unit)
+  let f2 = (_:int, _) => ()
+  let _ = f2 :> ((t, _) => unit)
+}
+
+
+module Totallypoly = {
+  let f = x => (x :> int)
+  let idint = (x:int) => x
+  let _ = f === idint
+}