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 #6828

Author: cristianoc

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,13 +2571,13 @@ 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 (arg, ty',cty') =
+        match () with
+        | () ->
             let (cty', force) =
               Typetexp.transl_simple_type_delayed env sty'
             in
@@ -2620,38 +2620,15 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg=Rejected) env sexp ty
                         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;
-            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')
+            (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 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 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"]

jscomp/syntax/src/res_comments_table.ml

@@ -1005,27 +1005,12 @@ and walk_expression expr t comments =
       attach t.leading expr.pexp_loc leading;
       walk_expression expr t inside;
       attach t.trailing expr.pexp_loc trailing
-  | Pexp_coerce (expr, opt_typexpr, typexpr) ->
+  | Pexp_coerce (expr, (), typexpr) ->
     let leading, inside, trailing = partition_by_loc comments expr.pexp_loc in
     attach t.leading expr.pexp_loc leading;
     walk_expression expr t inside;
     let after_expr, rest = partition_adjacent_trailing expr.pexp_loc trailing in
     attach t.trailing expr.pexp_loc after_expr;
-    let rest =
-      match opt_typexpr with
-      | Some typexpr ->
-        let leading, inside, trailing =
-          partition_by_loc comments typexpr.ptyp_loc
-        in
-        attach t.leading typexpr.ptyp_loc leading;
-        walk_core_type typexpr t inside;
-        let after_typ, rest =
-          partition_adjacent_trailing typexpr.ptyp_loc trailing
-        in
-        attach t.trailing typexpr.ptyp_loc after_typ;
-        rest
-      | None -> rest
-    in
     let leading, inside, trailing = partition_by_loc rest typexpr.ptyp_loc in
     attach t.leading typexpr.ptyp_loc leading;
     walk_core_type typexpr t inside;

jscomp/syntax/src/res_core.ml

@@ -1860,7 +1860,7 @@ and parse_coerced_expr ~(expr : Parsetree.expression) p =
   Parser.expect ColonGreaterThan p;
   let typ = parse_typ_expr p in
   let loc = mk_loc expr.pexp_loc.loc_start p.prev_end_pos in
-  Ast_helper.Exp.coerce ~loc expr None typ
+  Ast_helper.Exp.coerce ~loc expr typ
 
 and parse_constrained_or_coerced_expr p =
   let expr = parse_expr p in

jscomp/syntax/src/res_printer.ml

@@ -3300,17 +3300,10 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl =
         ]
     | Pexp_function cases ->
       Doc.concat [Doc.text "x => switch x "; print_cases ~state cases cmt_tbl]
-    | Pexp_coerce (expr, typ_opt, typ) ->
+    | Pexp_coerce (expr, (), typ) ->
       let doc_expr = print_expression_with_comments ~state expr cmt_tbl in
       let doc_typ = print_typ_expr ~state typ cmt_tbl in
-      let of_type =
-        match typ_opt with
-        | None -> Doc.nil
-        | Some typ1 ->
-          Doc.concat [Doc.text ": "; print_typ_expr ~state typ1 cmt_tbl]
-      in
-      Doc.concat
-        [Doc.lparen; doc_expr; of_type; Doc.text " :> "; doc_typ; Doc.rparen]
+      Doc.concat [Doc.lparen; doc_expr; Doc.text " :> "; doc_typ; Doc.rparen]
     | Pexp_send (parent_expr, label) ->
       let parent_doc =
         let doc = print_expression_with_comments ~state parent_expr cmt_tbl in