From ed4f755f6fa168b325c6f9eb918e849f8a8f181c Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 25 Jun 2024 10:56:36 +0200 Subject: [PATCH 1/3] 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 https://github.com/rescript-lang/rescript-compiler/pull/6828 --- jscomp/frontend/bs_ast_mapper.ml | 6 ++-- jscomp/ml/ast_helper.ml | 2 +- jscomp/ml/ast_helper.mli | 2 +- jscomp/ml/ast_iterator.ml | 4 +-- jscomp/ml/ast_mapper.ml | 4 +-- jscomp/ml/depend.ml | 3 +- jscomp/ml/parser.ml | 6 ++-- jscomp/ml/parser.mly | 2 +- jscomp/ml/parsetree.ml | 3 +- jscomp/ml/pprintast.ml | 5 ++-- jscomp/ml/printast.ml | 3 +- jscomp/ml/printtyped.ml | 3 +- jscomp/ml/tast_mapper.ml | 4 +-- jscomp/ml/typecore.ml | 39 +++++-------------------- jscomp/ml/typedtree.ml | 2 +- jscomp/ml/typedtree.mli | 5 ++-- jscomp/ml/typedtreeIter.ml | 4 +-- jscomp/ml/typedtreeMap.ml | 7 ++--- jscomp/ml/untypeast.ml | 4 +-- jscomp/syntax/src/res_ast_debugger.ml | 12 ++------ jscomp/syntax/src/res_comments_table.ml | 17 +---------- jscomp/syntax/src/res_core.ml | 2 +- jscomp/syntax/src/res_printer.ml | 11 ++----- 23 files changed, 43 insertions(+), 107 deletions(-) diff --git a/jscomp/frontend/bs_ast_mapper.ml b/jscomp/frontend/bs_ast_mapper.ml index 1c22504682..a0ff1a7fc0 100644 --- a/jscomp/frontend/bs_ast_mapper.ml +++ b/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) diff --git a/jscomp/ml/ast_helper.ml b/jscomp/ml/ast_helper.ml index 4c372aa7af..42d803ae9f 100644 --- a/jscomp/ml/ast_helper.ml +++ b/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)) diff --git a/jscomp/ml/ast_helper.mli b/jscomp/ml/ast_helper.mli index 355cbc55ab..122862d0a7 100644 --- a/jscomp/ml/ast_helper.mli +++ 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 diff --git a/jscomp/ml/ast_iterator.ml b/jscomp/ml/ast_iterator.ml index 8d2885b819..c5826d5493 100755 --- a/jscomp/ml/ast_iterator.ml +++ b/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 diff --git a/jscomp/ml/ast_mapper.ml b/jscomp/ml/ast_mapper.ml index 710414c0b7..0475aa6ad4 100644 --- a/jscomp/ml/ast_mapper.ml +++ b/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) diff --git a/jscomp/ml/depend.ml b/jscomp/ml/depend.ml index 1d2c46279d..0daaa97f56 100644 --- a/jscomp/ml/depend.ml +++ b/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; diff --git a/jscomp/ml/parser.ml b/jscomp/ml/parser.ml index 44a14d728b..c0b5334852 100644 --- a/jscomp/ml/parser.ml +++ b/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 -> diff --git a/jscomp/ml/parser.mly b/jscomp/ml/parser.mly index 515605979f..c35fc5b505 100644 --- a/jscomp/ml/parser.mly +++ b/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 diff --git a/jscomp/ml/parsetree.ml b/jscomp/ml/parsetree.ml index 726273d8a8..cb2a274d54 100644 --- a/jscomp/ml/parsetree.ml +++ b/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 *) diff --git a/jscomp/ml/pprintast.ml b/jscomp/ml/pprintast.ml index 3adcf44f59..cfc113cb27 100644 --- a/jscomp/ml/pprintast.ml +++ b/jscomp/ml/pprintast.ml @@ -707,9 +707,8 @@ and simple_expr ctxt f x = pp f "@[(%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) -> diff --git a/jscomp/ml/printast.ml b/jscomp/ml/printast.ml index 04d7d96b86..d181935b84 100644 --- a/jscomp/ml/printast.ml +++ b/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; diff --git a/jscomp/ml/printtyped.ml b/jscomp/ml/printtyped.ml index a6527a6275..f9acae1943 100644 --- a/jscomp/ml/printtyped.ml +++ b/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; diff --git a/jscomp/ml/tast_mapper.ml b/jscomp/ml/tast_mapper.ml index cae78def91..0c8ddc7ea7 100644 --- a/jscomp/ml/tast_mapper.ml +++ b/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 diff --git a/jscomp/ml/typecore.ml b/jscomp/ml/typecore.ml index 9972b08d4f..53fe350f1c 100644 --- a/jscomp/ml/typecore.ml +++ b/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,30 +2620,7 @@ 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; @@ -2651,7 +2628,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg=Rejected) env sexp ty 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}) -> diff --git a/jscomp/ml/typedtree.ml b/jscomp/ml/typedtree.ml index 7cb8d920ec..4baf61f7fa 100644 --- a/jscomp/ml/typedtree.ml +++ b/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 diff --git a/jscomp/ml/typedtree.mli b/jscomp/ml/typedtree.mli index 80fc04c35b..82b45b6080 100644 --- a/jscomp/ml/typedtree.mli +++ b/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)] diff --git a/jscomp/ml/typedtreeIter.ml b/jscomp/ml/typedtreeIter.ml index 6f37a07471..2f57f5cf20 100644 --- a/jscomp/ml/typedtreeIter.ml +++ b/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 _ -> ()) diff --git a/jscomp/ml/typedtreeMap.ml b/jscomp/ml/typedtreeMap.ml index 442968a69f..cf388a0983 100644 --- a/jscomp/ml/typedtreeMap.ml +++ b/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 _ diff --git a/jscomp/ml/untypeast.ml b/jscomp/ml/untypeast.ml index 77823db52f..da060b183e 100644 --- a/jscomp/ml/untypeast.ml +++ b/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) diff --git a/jscomp/syntax/src/res_ast_debugger.ml b/jscomp/syntax/src/res_ast_debugger.ml index 7c6b5d3237..4bb3d5a965 100644 --- a/jscomp/syntax/src/res_ast_debugger.ml +++ b/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"] diff --git a/jscomp/syntax/src/res_comments_table.ml b/jscomp/syntax/src/res_comments_table.ml index b531fde329..3170fec71e 100644 --- a/jscomp/syntax/src/res_comments_table.ml +++ b/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; diff --git a/jscomp/syntax/src/res_core.ml b/jscomp/syntax/src/res_core.ml index 83ecf4924b..e0c7cdf790 100644 --- a/jscomp/syntax/src/res_core.ml +++ b/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 diff --git a/jscomp/syntax/src/res_printer.ml b/jscomp/syntax/src/res_printer.ml index 109a053bca..e2a54cf084 100644 --- a/jscomp/syntax/src/res_printer.ml +++ b/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 From 19abd9fb2ac74b265e2a3fb89c6b0be203bda6b2 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 25 Jun 2024 10:58:46 +0200 Subject: [PATCH 2/3] Cleanup and indent. --- jscomp/ml/typecore.ml | 88 +++++++++++++++++++++---------------------- 1 file changed, 43 insertions(+), 45 deletions(-) diff --git a/jscomp/ml/typecore.ml b/jscomp/ml/typecore.ml index 53fe350f1c..04d7e38c1e 100644 --- a/jscomp/ml/typecore.ml +++ b/jscomp/ml/typecore.ml @@ -2576,51 +2576,49 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg=Rejected) env sexp ty (* Also see PR#7199 for a problem with the following: let separate = Env.has_local_constraints env in*) let (arg, ty',cty') = - match () with - | () -> - 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', 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 (); + 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; From 8af7d6c85497c7e854a7ed9ac171065fb5a8bc84 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 2 Jul 2024 11:17:02 +0200 Subject: [PATCH 3/3] Make Texp_coerce compatible with old runtime representation. By adding a unit argument to the payload. --- CHANGELOG.md | 1 + jscomp/ml/printtyped.ml | 2 +- jscomp/ml/tast_mapper.ml | 4 ++-- jscomp/ml/typecore.ml | 2 +- jscomp/ml/typedtree.ml | 2 +- jscomp/ml/typedtree.mli | 2 +- jscomp/ml/typedtreeIter.ml | 2 +- jscomp/ml/typedtreeMap.ml | 4 ++-- jscomp/ml/untypeast.ml | 2 +- 9 files changed, 11 insertions(+), 10 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index a46c7f750a..a7767e387e 100644 --- a/CHANGELOG.md +++ b/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 diff --git a/jscomp/ml/printtyped.ml b/jscomp/ml/printtyped.ml index f9acae1943..5b514ac36e 100644 --- a/jscomp/ml/printtyped.ml +++ b/jscomp/ml/printtyped.ml @@ -270,7 +270,7 @@ and expression_extra i ppf x attrs = line i ppf "Texp_constraint\n"; attributes i ppf attrs; core_type i ppf ct; - | Texp_coerce cto2 -> + | Texp_coerce ((), cto2) -> line i ppf "Texp_coerce\n"; attributes i ppf attrs; core_type i ppf cto2; diff --git a/jscomp/ml/tast_mapper.ml b/jscomp/ml/tast_mapper.ml index 0c8ddc7ea7..76c2e72fc2 100644 --- a/jscomp/ml/tast_mapper.ml +++ b/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 cty2 -> - Texp_coerce (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 diff --git a/jscomp/ml/typecore.ml b/jscomp/ml/typecore.ml index 04d7e38c1e..7387ebbcc7 100644 --- a/jscomp/ml/typecore.ml +++ b/jscomp/ml/typecore.ml @@ -2626,7 +2626,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg=Rejected) env sexp ty exp_type = ty'; exp_attributes = arg.exp_attributes; exp_env = env; - exp_extra = (Texp_coerce cty', loc, sexp.pexp_attributes) :: + exp_extra = (Texp_coerce ((), cty'), loc, sexp.pexp_attributes) :: arg.exp_extra; } | Pexp_send (e, {txt=met}) -> diff --git a/jscomp/ml/typedtree.ml b/jscomp/ml/typedtree.ml index 4baf61f7fa..3cc1b9bbc4 100644 --- a/jscomp/ml/typedtree.ml +++ b/jscomp/ml/typedtree.ml @@ -68,7 +68,7 @@ and expression = and exp_extra = | Texp_constraint of core_type - | Texp_coerce of 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 diff --git a/jscomp/ml/typedtree.mli b/jscomp/ml/typedtree.mli index 82b45b6080..60eea19bc4 100644 --- a/jscomp/ml/typedtree.mli +++ b/jscomp/ml/typedtree.mli @@ -119,7 +119,7 @@ and expression = and exp_extra = | Texp_constraint of core_type (** E : T *) - | Texp_coerce of core_type + | Texp_coerce of unit * core_type (** E :> T [Texp_coerce T] *) | Texp_open of override_flag * Path.t * Longident.t loc * Env.t diff --git a/jscomp/ml/typedtreeIter.ml b/jscomp/ml/typedtreeIter.ml index 2f57f5cf20..5c5c0de70e 100644 --- a/jscomp/ml/typedtreeIter.ml +++ b/jscomp/ml/typedtreeIter.ml @@ -236,7 +236,7 @@ module MakeIterator(Iter : IteratorArgument) : sig match cstr with Texp_constraint ct -> iter_core_type ct - | Texp_coerce cty2 -> + | Texp_coerce ((), cty2) -> iter_core_type cty2 | Texp_open _ -> () | Texp_poly cto -> option iter_core_type cto diff --git a/jscomp/ml/typedtreeMap.ml b/jscomp/ml/typedtreeMap.ml index cf388a0983..9899275b97 100644 --- a/jscomp/ml/typedtreeMap.ml +++ b/jscomp/ml/typedtreeMap.ml @@ -362,8 +362,8 @@ module MakeMap(Map : MapArgument) = struct match desc with | Texp_constraint ct -> Texp_constraint (map_core_type ct), loc, attrs - | Texp_coerce ct -> - Texp_coerce (map_core_type ct), 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 _ diff --git a/jscomp/ml/untypeast.ml b/jscomp/ml/untypeast.ml index da060b183e..74fb0d1dba 100644 --- a/jscomp/ml/untypeast.ml +++ b/jscomp/ml/untypeast.ml @@ -305,7 +305,7 @@ let exp_extra sub (extra, loc, attrs) sexp = let attrs = sub.attributes sub attrs in let desc = match extra with - Texp_coerce cty2 -> + Texp_coerce ((), cty2) -> Pexp_coerce (sexp, (), sub.typ sub cty2)