Skip to content

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

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 3 commits into from
Jul 2, 2024
Merged

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

Show file tree
Hide file tree
Changes from 2 commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
ed4f755
Remove coercion with 2 types, which is only supported in ml syntax.
cristianoc Jun 25, 2024
19abd9f
Cleanup and indent.
cristianoc Jun 25, 2024
8af7d6c
Make Texp_coerce compatible with old runtime representation.
cristianoc Jul 2, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
6 changes: 2 additions & 4 deletions jscomp/frontend/bs_ast_mapper.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down
2 changes: 1 addition & 1 deletion jscomp/ml/ast_helper.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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))
Expand Down
2 changes: 1 addition & 1 deletion jscomp/ml/ast_helper.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
4 changes: 2 additions & 2 deletions jscomp/ml/ast_iterator.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
4 changes: 2 additions & 2 deletions jscomp/ml/ast_mapper.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down
3 changes: 1 addition & 2 deletions jscomp/ml/depend.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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;
Expand Down
6 changes: 3 additions & 3 deletions jscomp/ml/parser.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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))
Expand All @@ -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 ->
Expand Down
2 changes: 1 addition & 1 deletion jscomp/ml/parser.mly
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
3 changes: 1 addition & 2 deletions jscomp/ml/parsetree.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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 *)
Expand Down
5 changes: 2 additions & 3 deletions jscomp/ml/pprintast.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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) ->
Expand Down
3 changes: 1 addition & 2 deletions jscomp/ml/printast.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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;
Expand Down
3 changes: 1 addition & 2 deletions jscomp/ml/printtyped.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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;
Expand Down
4 changes: 2 additions & 2 deletions jscomp/ml/tast_mapper.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
117 changes: 46 additions & 71 deletions jscomp/ml/typecore.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)))
Expand Down Expand Up @@ -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}) ->
Expand Down
2 changes: 1 addition & 1 deletion jscomp/ml/typedtree.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
5 changes: 2 additions & 3 deletions jscomp/ml/typedtree.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Will this be problematic for the editor tooling/other things that read the compiler artifacts?

@zth good question.
This should be Texp_coerce of unit * core_type so for old compiler versions will produce a .cmt that has the rhs core_type in the right place (and the lhs apparing to be None).

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

That'll make it work I take it?

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I have no idea how things are represented in OCaml and what can break.

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

At runtime unit is 0 just like None, so the new representation will generate files that appear as valid also in the old representation.

(** 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)]
Expand Down
4 changes: 2 additions & 2 deletions jscomp/ml/typedtreeIter.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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 _ -> ())
Expand Down
7 changes: 2 additions & 5 deletions jscomp/ml/typedtreeMap.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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 _
Expand Down
4 changes: 2 additions & 2 deletions jscomp/ml/untypeast.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down
12 changes: 2 additions & 10 deletions jscomp/syntax/src/res_ast_debugger.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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"]
Expand Down
Loading