Remove coercion with 2 types, which is only supported in ml syntax. (rescript-lang#6829)

* Remove coercion with 2 types, which is only supported in ml syntax.

There are two forms of type coercion:
1 `e: t0 :> t`
2 `e :> t`

The first form was never supported in .res syntax, and is now removed from parsed and typed tree.

That said, coercion 1 is the only one that ever supported coercion with free variables. So this is subject to more investigation.

See rescript-lang#6828

* Cleanup and indent.

* Make Texp_coerce compatible with old runtime representation.

By adding a unit argument to the payload.

Author: cristianoc

CHANGELOG.md

@@ -42,6 +42,7 @@
 - Refactor uppercase exotic ident handling. https://github.com/rescript-lang/rescript-compiler/pull/6779
 - Fix `-nostdlib` internal compiler option. https://github.com/rescript-lang/rescript-compiler/pull/6824
 - Remove a number of ast nodes never populated by the .res parser, and resulting dead code. https://github.com/rescript-lang/rescript-compiler/pull/6830
+- Remove coercion with 2 types from internal representation. Coercion `e : t1 :> t2` was only supported in `.ml` syntax and never by the `.res` parser. https://github.com/rescript-lang/rescript-compiler/pull/6829 
 
 #### :nail_care: Polish
 

jscomp/frontend/bs_ast_mapper.ml

@@ -349,10 +349,8 @@ module E = struct
     | Pexp_for (p, e1, e2, d, e3) ->
       for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d
         (sub.expr sub e3)
-    | Pexp_coerce (e, t1, t2) ->
-      coerce ~loc ~attrs (sub.expr sub e)
-        (map_opt (sub.typ sub) t1)
-        (sub.typ sub t2)
+    | Pexp_coerce (e, (), t2) ->
+      coerce ~loc ~attrs (sub.expr sub e) (sub.typ sub t2)
     | Pexp_constraint (e, t) ->
       constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t)
     | Pexp_send (e, s) -> send ~loc ~attrs (sub.expr sub e) (map_loc sub s)

jscomp/ml/ast_helper.ml

@@ -171,7 +171,7 @@ module Exp = struct
   let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b))
   let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e))
   let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b))
-  let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c))
+  let coerce ?loc ?attrs a c = mk ?loc ?attrs (Pexp_coerce (a, (), c))
   let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b))
   let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a)
   let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b))

jscomp/ml/ast_helper.mli

@@ -146,7 +146,7 @@ module Exp:
                 -> expression
     val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression
               -> direction_flag -> expression -> expression
-    val coerce: ?loc:loc -> ?attrs:attrs -> expression -> core_type option
+    val coerce: ?loc:loc -> ?attrs:attrs -> expression
                 -> core_type -> expression
     val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type
                      -> expression

jscomp/ml/ast_iterator.ml

@@ -303,8 +303,8 @@ module E = struct
     | Pexp_for (p, e1, e2, _d, e3) ->
         sub.pat sub p; sub.expr sub e1; sub.expr sub e2;
         sub.expr sub e3
-    | Pexp_coerce (e, t1, t2) ->
-        sub.expr sub e; iter_opt (sub.typ sub) t1;
+    | Pexp_coerce (e, (), t2) ->
+        sub.expr sub e;
         sub.typ sub t2
     | Pexp_constraint (e, t) ->
         sub.expr sub e; sub.typ sub t

jscomp/ml/ast_mapper.ml

@@ -314,8 +314,8 @@ module E = struct
     | Pexp_for (p, e1, e2, d, e3) ->
         for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d
           (sub.expr sub e3)
-    | Pexp_coerce (e, t1, t2) ->
-        coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1)
+    | Pexp_coerce (e, (), t2) ->
+        coerce ~loc ~attrs (sub.expr sub e)
           (sub.typ sub t2)
     | Pexp_constraint (e, t) ->
         constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t)

jscomp/ml/depend.ml

@@ -218,9 +218,8 @@ let rec add_expr bv exp =
   | Pexp_while(e1, e2) -> add_expr bv e1; add_expr bv e2
   | Pexp_for( _, e1, e2, _, e3) ->
       add_expr bv e1; add_expr bv e2; add_expr bv e3
-  | Pexp_coerce(e1, oty2, ty3) ->
+  | Pexp_coerce(e1, (), ty3) ->
       add_expr bv e1;
-      add_opt add_type bv oty2;
       add_type bv ty3
   | Pexp_constraint(e1, ty2) ->
       add_expr bv e1;

jscomp/ml/parser.ml

@@ -241,7 +241,7 @@ let mkstrexp e attrs =
 let mkexp_constraint e (t1, t2) =
   match t1, t2 with
   | Some t, None -> ghexp(Pexp_constraint(e, t))
-  | _, Some t -> ghexp(Pexp_coerce(e, t1, t))
+  | _, Some t -> ghexp(Pexp_coerce(e, (), t))
   | None, None -> assert false
 
 let mkexp_opt_constraint e = function
@@ -6554,7 +6554,7 @@ let yyact = [|
 # 648 "ml/parser.mly"
       ( mkmod ~attrs:_3
           (Pmod_unpack(
-               ghexp(Pexp_coerce(_4, Some(ghtyp(Ptyp_package _6)),
+               ghexp(Pexp_coerce(_4, (),
                                  ghtyp(Ptyp_package _8))))) )
 # 6565 "ml/parser.ml"
                : 'paren_module_expr))
@@ -6566,7 +6566,7 @@ let yyact = [|
 # 653 "ml/parser.mly"
       ( mkmod ~attrs:_3
           (Pmod_unpack(
-               ghexp(Pexp_coerce(_4, None, ghtyp(Ptyp_package _6))))) )
+               ghexp(Pexp_coerce(_4, (), ghtyp(Ptyp_package _6))))) )
 # 6576 "ml/parser.ml"
                : 'paren_module_expr))
 ; (fun __caml_parser_env ->

jscomp/ml/parser.mly

@@ -135,7 +135,7 @@ let mkstrexp e attrs =
 let mkexp_constraint e (t1, t2) =
   match t1, t2 with
   | Some t, None -> ghexp(Pexp_constraint(e, t))
-  | _, Some t -> ghexp(Pexp_coerce(e, t1, t))
+  | _, Some t -> ghexp(Pexp_coerce(e, (), t))
   | None, None -> assert false
 
 let mkexp_opt_constraint e = function

jscomp/ml/parsetree.ml

@@ -307,9 +307,8 @@ and expression_desc =
          *)
   | Pexp_constraint of expression * core_type
         (* (E : T) *)
-  | Pexp_coerce of expression * core_type option * core_type
+  | Pexp_coerce of expression * unit * core_type
         (* (E :> T)        (None, T)
-           (E : T0 :> T)   (Some T0, T)
          *)
   | Pexp_send of expression * label loc
         (*  E # m *)

jscomp/ml/pprintast.ml

@@ -707,9 +707,8 @@ and simple_expr ctxt f x =
         pp f "@[<hov2>(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l
     | Pexp_constraint (e, ct) ->
         pp f "(%a : %a)" (expression ctxt) e (core_type ctxt) ct
-    | Pexp_coerce (e, cto1, ct) ->
-        pp f "(%a%a :> %a)" (expression ctxt) e
-          (option (core_type ctxt) ~first:" : " ~last:" ") cto1 (* no sep hint*)
+    | Pexp_coerce (e, (), ct) ->
+        pp f "(%a :> %a)" (expression ctxt) e
           (core_type ctxt) ct
     | Pexp_variant (l, None) -> pp f "`%s" l
     | Pexp_record (l, eo) ->

jscomp/ml/printast.ml

@@ -321,10 +321,9 @@ and expression i ppf x =
       line i ppf "Pexp_constraint\n";
       expression i ppf e;
       core_type i ppf ct;
-  | Pexp_coerce (e, cto1, cto2) ->
+  | Pexp_coerce (e, (), cto2) ->
       line i ppf "Pexp_coerce\n";
       expression i ppf e;
-      option i core_type ppf cto1;
       core_type i ppf cto2;
   | Pexp_send (e, s) ->
       line i ppf "Pexp_send \"%s\"\n" s.txt;

jscomp/ml/printtyped.ml

@@ -270,10 +270,9 @@ and expression_extra i ppf x attrs =
       line i ppf "Texp_constraint\n";
       attributes i ppf attrs;
       core_type i ppf ct;
-  | Texp_coerce (cto1, cto2) ->
+  | Texp_coerce ((), cto2) ->
       line i ppf "Texp_coerce\n";
       attributes i ppf attrs;
-      option i core_type ppf cto1;
       core_type i ppf cto2;
   | Texp_open (ovf, m, _, _) ->
       line i ppf "Texp_open %a \"%a\"\n" fmt_override_flag ovf fmt_path m;

jscomp/ml/tast_mapper.ml

@@ -190,8 +190,8 @@ let expr sub x =
   let extra = function
     | Texp_constraint cty ->
         Texp_constraint (sub.typ sub cty)
-    | Texp_coerce (cty1, cty2) ->
-        Texp_coerce (opt (sub.typ sub) cty1, sub.typ sub cty2)
+    | Texp_coerce ((), cty2) ->
+        Texp_coerce ((), (sub.typ sub cty2))
     | Texp_open (ovf, path, loc, env) ->
         Texp_open (ovf, path, loc, sub.env sub env)
     | Texp_newtype _ as d -> d

jscomp/ml/typecore.ml

@@ -1709,13 +1709,13 @@ let rec type_approx env sexp =
         raise(Error(sexp.pexp_loc, env, Expr_type_clash (trace, None)))
       end;
       ty1
-  | Pexp_coerce (e, sty1, sty2) ->
+  | Pexp_coerce (e, (), sty2) ->
       let approx_ty_opt = function
         | None -> newvar ()
         | Some sty -> approx_type env sty
       in
       let ty = type_approx env e
-      and ty1 = approx_ty_opt sty1
+      and ty1 = approx_ty_opt None
       and ty2 = approx_type env sty2 in
       begin try unify env ty ty1 with Unify trace ->
         raise(Error(sexp.pexp_loc, env, Expr_type_clash (trace, None)))
@@ -2571,87 +2571,62 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg=Rejected) env sexp ty
         exp_extra =
           (Texp_constraint cty, loc, sexp.pexp_attributes) :: arg.exp_extra;
       }
-  | Pexp_coerce(sarg, sty, sty') ->
+  | Pexp_coerce(sarg, (), sty') ->
       let separate = true in (* always separate, 1% slowdown for lablgtk *)
       (* Also see PR#7199 for a problem with the following:
          let separate =  Env.has_local_constraints env in*)
-      let (arg, ty',cty,cty') =
-        match sty with
-        | None ->
-            let (cty', force) =
-              Typetexp.transl_simple_type_delayed env sty'
-            in
-            let ty' = cty'.ctyp_type in
-            if separate then begin_def ();
-            let arg = type_exp env sarg in
-            let gen =
-              if separate then begin
-                end_def ();
-                let tv = newvar () in
-                let gen = generalizable tv.level arg.exp_type in
-                (try unify_var env tv arg.exp_type with Unify trace ->
-                  raise(Error(arg.exp_loc, env, Expr_type_clash (trace, type_clash_context))));
-                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
-            end;
-            (arg, ty', None, cty')
-        | Some sty ->
-            if separate then begin_def ();
-            let (cty, force) =
-              Typetexp.transl_simple_type_delayed env sty
-            and (cty', force') =
-              Typetexp.transl_simple_type_delayed env sty'
-            in
-            let ty = cty.ctyp_type in
-            let ty' = cty'.ctyp_type in
-            begin try
-              let force'' = subtype env ty ty' in
-              force (); force' (); force'' ()
-            with Subtype (tr1, tr2) ->
-              raise(Error(loc, env, Not_subtype(tr1, tr2)))
-            end;
+      let (arg, ty',cty') =
+          let (cty', force) =
+            Typetexp.transl_simple_type_delayed env sty'
+          in
+          let ty' = cty'.ctyp_type in
+          if separate then begin_def ();
+          let arg = type_exp env sarg in
+          let gen =
             if separate then begin
               end_def ();
-              generalize_structure ty;
-              generalize_structure ty';
-              (type_argument env sarg ty (instance env ty),
-               instance env ty', Some cty, cty')
-            end else
-              (type_argument env sarg ty ty, ty', Some cty, cty')
+              let tv = newvar () in
+              let gen = generalizable tv.level arg.exp_type in
+              (try unify_var env tv arg.exp_type with Unify trace ->
+                raise(Error(arg.exp_loc, env, Expr_type_clash (trace, type_clash_context))));
+              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
+          end;
+          (arg, ty', cty')
       in
       rue {
         exp_desc = arg.exp_desc;
         exp_loc = arg.exp_loc;
         exp_type = ty';
         exp_attributes = arg.exp_attributes;
         exp_env = env;
-        exp_extra = (Texp_coerce (cty, cty'), loc, sexp.pexp_attributes) ::
+        exp_extra = (Texp_coerce ((), cty'), loc, sexp.pexp_attributes) ::
                        arg.exp_extra;
       }
   | Pexp_send (e, {txt=met}) ->

jscomp/ml/typedtree.ml

@@ -68,7 +68,7 @@ and expression =
 
 and exp_extra =
   | Texp_constraint of core_type
-  | Texp_coerce of core_type option * core_type
+  | Texp_coerce of unit * core_type
   | Texp_open of override_flag * Path.t * Longident.t loc * Env.t
   | Texp_poly of core_type option
   | Texp_newtype of string

jscomp/ml/typedtree.mli

@@ -119,9 +119,8 @@ and expression =
 and exp_extra =
   | Texp_constraint of core_type
         (** E : T *)
-  | Texp_coerce of core_type option * core_type
-        (** E :> T           [Texp_coerce (None, T)]
-            E : T0 :> T      [Texp_coerce (Some T0, T)]
+  | Texp_coerce of unit * core_type
+        (** E :> T           [Texp_coerce T]
          *)
   | Texp_open of override_flag * Path.t * Longident.t loc * Env.t
         (** let open[!] M in    [Texp_open (!, P, M, env)]

jscomp/ml/typedtreeIter.ml

@@ -236,8 +236,8 @@ module MakeIterator(Iter : IteratorArgument) : sig
         match cstr with
           Texp_constraint ct ->
             iter_core_type ct
-        | Texp_coerce (cty1, cty2) ->
-            option iter_core_type cty1; iter_core_type cty2
+        | Texp_coerce ((), cty2) ->
+            iter_core_type cty2
         | Texp_open _ -> ()
         | Texp_poly cto -> option iter_core_type cto
         | Texp_newtype _ -> ())

jscomp/ml/typedtreeMap.ml

@@ -362,11 +362,8 @@ module MakeMap(Map : MapArgument) = struct
     match desc with
       | Texp_constraint ct ->
         Texp_constraint (map_core_type ct), loc, attrs
-      | Texp_coerce (None, ct) ->
-        Texp_coerce (None, map_core_type ct), loc, attrs
-      | Texp_coerce (Some ct1, ct2) ->
-        Texp_coerce (Some (map_core_type ct1),
-                         map_core_type ct2), loc, attrs
+      | Texp_coerce ((), ct) ->
+        Texp_coerce ((), map_core_type ct), loc, attrs
       | Texp_poly (Some ct) ->
         Texp_poly (Some ( map_core_type ct )), loc, attrs
       | Texp_newtype _

jscomp/ml/untypeast.ml

@@ -305,9 +305,9 @@ let exp_extra sub (extra, loc, attrs) sexp =
   let attrs = sub.attributes sub attrs in
   let desc =
     match extra with
-      Texp_coerce (cty1, cty2) ->
+      Texp_coerce ((), cty2) ->
         Pexp_coerce (sexp,
-                     map_opt (sub.typ sub) cty1,
+                     (),
                      sub.typ sub cty2)
     | Texp_constraint cty ->
         Pexp_constraint (sexp, sub.typ sub cty)

jscomp/syntax/src/res_ast_debugger.ml

@@ -678,16 +678,8 @@ module SexpAst = struct
       | Pexp_constraint (expr, typexpr) ->
         Sexp.list
           [Sexp.atom "Pexp_constraint"; expression expr; core_type typexpr]
-      | Pexp_coerce (expr, opt_typ, typexpr) ->
-        Sexp.list
-          [
-            Sexp.atom "Pexp_coerce";
-            expression expr;
-            (match opt_typ with
-            | None -> Sexp.atom "None"
-            | Some typ -> Sexp.list [Sexp.atom "Some"; core_type typ]);
-            core_type typexpr;
-          ]
+      | Pexp_coerce (expr, (), typexpr) ->
+        Sexp.list [Sexp.atom "Pexp_coerce"; expression expr; core_type typexpr]
       | Pexp_send _ -> Sexp.list [Sexp.atom "Pexp_send"]
       | Pexp_new _ -> Sexp.list [Sexp.atom "Pexp_new"]
       | Pexp_setinstvar _ -> Sexp.list [Sexp.atom "Pexp_setinstvar"]