From 79a38769ff355b55eb6b86fdabcee43bafb0fc1b Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Thu, 12 Dec 2024 10:52:27 +0100 Subject: [PATCH] wip remove Function$ --- compiler/frontend/ast_derive_js_mapper.ml | 6 ++-- compiler/frontend/ast_derive_projector.ml | 8 ++--- compiler/ml/ast_uncurried.ml | 16 +++------ compiler/ml/translcore.ml | 40 ++++++++++------------- compiler/ml/typecore.ml | 33 ++++++++----------- compiler/syntax/src/jsx_v4.ml | 3 +- compiler/syntax/src/res_comments_table.ml | 2 -- compiler/syntax/src/res_core.ml | 8 ++--- compiler/syntax/src/res_parens.ml | 11 ------- compiler/syntax/src/res_printer.ml | 14 +------- 10 files changed, 46 insertions(+), 95 deletions(-) diff --git a/compiler/frontend/ast_derive_js_mapper.ml b/compiler/frontend/ast_derive_js_mapper.ml index ca10a03da1..cb2f7385b7 100644 --- a/compiler/frontend/ast_derive_js_mapper.ml +++ b/compiler/frontend/ast_derive_js_mapper.ml @@ -169,7 +169,7 @@ let init () = in let to_js_body body = Ast_comb.single_non_rec_value pat_to_js - (Ast_uncurried.uncurried_fun ~loc:Location.none ~arity:1 + (Ast_uncurried.uncurried_fun ~arity:1 (Ast_compatible.fun_ ~arity:None (Pat.constraint_ (Pat.var pat_param) core_type) body)) @@ -214,7 +214,7 @@ let init () = in let from_js = Ast_comb.single_non_rec_value pat_from_js - (Ast_uncurried.uncurried_fun ~loc:Location.none ~arity:1 + (Ast_uncurried.uncurried_fun ~arity:1 (Ast_compatible.fun_ ~arity:(Some 1) (Pat.var pat_param) (if create_type then Exp.let_ Nonrecursive @@ -260,7 +260,7 @@ let init () = app2 unsafe_index_get_exp exp_map exp_param else app1 erase_type_exp exp_param); Ast_comb.single_non_rec_value pat_from_js - (Ast_uncurried.uncurried_fun ~loc:Location.none ~arity:1 + (Ast_uncurried.uncurried_fun ~arity:1 (Ast_compatible.fun_ ~arity:(Some 1) (Pat.var pat_param) (let result = diff --git a/compiler/frontend/ast_derive_projector.ml b/compiler/frontend/ast_derive_projector.ml index 86514c4ef0..2fab2e2a3b 100644 --- a/compiler/frontend/ast_derive_projector.ml +++ b/compiler/frontend/ast_derive_projector.ml @@ -20,9 +20,9 @@ let init () = { structure_gen = (fun (tdcls : tdcls) _explict_nonrec -> - let handle_uncurried_accessor_tranform ~loc ~arity accessor = + let handle_uncurried_accessor_tranform ~arity accessor = (* Accessors with no params (arity of 0) are simply values and not functions *) - if arity > 0 then Ast_uncurried.uncurried_fun ~loc ~arity accessor + if arity > 0 then Ast_uncurried.uncurried_fun ~arity accessor else accessor in let handle_tdcl tdcl = @@ -52,7 +52,7 @@ let init () = (Exp.ident {txt = Lident txt; loc}) {txt = Longident.Lident pld_label; loc}) (*arity will alwys be 1 since these are single param functions*) - |> handle_uncurried_accessor_tranform ~arity:1 ~loc)) + |> handle_uncurried_accessor_tranform ~arity:1)) | Ptype_variant constructor_declarations -> Ext_list.map constructor_declarations (fun @@ -111,7 +111,7 @@ let init () = Ast_compatible.fun_ ~arity:(Some 1) (Pat.var {loc; txt = var}) b) - |> handle_uncurried_accessor_tranform ~loc ~arity)) + |> handle_uncurried_accessor_tranform ~arity)) | Ptype_abstract | Ptype_open -> Ast_derive_util.not_applicable tdcl.ptype_loc deriving_name; [] diff --git a/compiler/ml/ast_uncurried.ml b/compiler/ml/ast_uncurried.ml index 883a8d7ded..9305d67d88 100644 --- a/compiler/ml/ast_uncurried.ml +++ b/compiler/ml/ast_uncurried.ml @@ -19,31 +19,23 @@ let uncurried_type ~loc ~arity t_arg = let t_arity = arity_type ~loc arity in Ast_helper.Typ.constr ~loc {txt = Lident "function$"; loc} [t_arg; t_arity] -let uncurried_fun ~loc ~arity fun_expr = +let uncurried_fun ~arity fun_expr = let fun_expr = match fun_expr.Parsetree.pexp_desc with | Pexp_fun (l, eo, p, e, _) -> {fun_expr with pexp_desc = Pexp_fun (l, eo, p, e, Some arity)} | _ -> assert false in - Ast_helper.Exp.construct ~loc - (Location.mknoloc (Longident.Lident "Function$")) - (Some fun_expr) + fun_expr let expr_is_uncurried_fun (expr : Parsetree.expression) = match expr.pexp_desc with - | Pexp_construct ({txt = Lident "Function$"}, Some _) -> true + | Pexp_fun (_, _, _, _, Some _) -> true | _ -> false let expr_extract_uncurried_fun (expr : Parsetree.expression) = match expr.pexp_desc with - | Pexp_construct ({txt = Lident "Function$"}, Some e) -> - let () = - match e.pexp_desc with - | Pexp_fun (_, _, _, _, Some _arity) -> () - | _ -> assert false - in - e + | Pexp_fun (_, _, _, _, Some _) -> expr | _ -> assert false let core_type_is_uncurried_fun (typ : Parsetree.core_type) = diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 59febcda45..bf1ead8729 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -674,7 +674,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | Texp_constant cst -> Lconst (Const_base cst) | Texp_let (rec_flag, pat_expr_list, body) -> transl_let rec_flag pat_expr_list (transl_exp body) - | Texp_function {arg_label = _; param; case; partial} -> + | Texp_function {arg_label = _; arity; param; case; partial} -> ( let async = has_async_attribute e in let directive = match extract_directive_for_fn e with @@ -695,7 +695,22 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = } in let loc = e.exp_loc in - Lfunction {params; body; attr; loc} + let lambda = Lfunction {params; body; attr; loc} in + match arity with + | Some arity -> + let prim = + match (Ctype.expand_head e.exp_env e.exp_type).desc with + | Tarrow (Nolabel, t, _, _) -> ( + match (Ctype.expand_head e.exp_env t).desc with + | Tconstr (Pident {name = "unit"}, [], _) -> Pjs_fn_make_unit + | _ -> Pjs_fn_make arity) + | _ -> Pjs_fn_make arity + in + Lprim + ( prim (* could be replaced with Opaque in the future except arity 0*), + [lambda], + loc ) + | None -> lambda) | Texp_apply ( ({ exp_desc = Texp_ident (_, _, {val_kind = Val_prim p}); @@ -781,27 +796,6 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = with Not_constant -> Lprim (Pmakeblock Blk_tuple, ll, e.exp_loc)) | Texp_construct ({txt = Lident "false"}, _, []) -> Lconst Const_false | Texp_construct ({txt = Lident "true"}, _, []) -> Lconst Const_true - | Texp_construct - ({txt = Lident "Function$"}, _, [({exp_desc = Texp_function _} as expr)]) - -> - (* ReScript uncurried encoding *) - let loc = expr.exp_loc in - let lambda = transl_exp expr in - let arity = - Ast_uncurried.uncurried_type_get_arity ~env:e.exp_env e.exp_type - in - let prim = - match (Ctype.expand_head expr.exp_env expr.exp_type).desc with - | Tarrow (Nolabel, t, _, _) -> ( - match (Ctype.expand_head expr.exp_env t).desc with - | Tconstr (Pident {name = "unit"}, [], _) -> Pjs_fn_make_unit - | _ -> Pjs_fn_make arity) - | _ -> Pjs_fn_make arity - in - Lprim - ( prim (* could be replaced with Opaque in the future except arity 0*), - [lambda], - loc ) | Texp_construct (lid, cstr, args) -> ( let ll = transl_list args in if cstr.cstr_inlined <> None then diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 992e64403d..50713a87ec 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -2525,25 +2525,6 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp exp_attributes = sexp.pexp_attributes; exp_env = env; } - | Pexp_construct - ( ({txt = Lident "Function$"} as lid), - (Some {pexp_desc = Pexp_fun (_, _, _, _, Some arity)} as sarg) ) -> - let state = Warnings.backup () in - let uncurried_typ = - Ast_uncurried.make_uncurried_type ~env ~arity (newvar ()) - in - unify_exp_types loc env uncurried_typ ty_expected; - (* Disable Unerasable_optional_argument for uncurried functions *) - let unerasable_optional_argument = - Warnings.number Unerasable_optional_argument - in - Warnings.parse_options false - ("-" ^ string_of_int unerasable_optional_argument); - let exp = - type_construct env loc lid sarg uncurried_typ sexp.pexp_attributes - in - Warnings.restore state; - exp | Pexp_construct (lid, sarg) -> type_construct env loc lid sarg ty_expected sexp.pexp_attributes | Pexp_variant (l, sarg) -> ( @@ -3273,7 +3254,19 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp | Pexp_extension ext -> raise (Error_forward (Builtin_attributes.error_of_extension ext)) -and type_function ?in_function ~arity loc attrs env ty_expected l caselist = +and type_function ?in_function ~arity loc attrs env ty_expected_ l caselist = + let ty_expected = + match arity with + | None -> + ty_expected_ + | Some arity -> + let fun_t = newvar() in + let uncurried_typ = + Ast_uncurried.make_uncurried_type ~env ~arity fun_t + in + unify_exp_types loc env uncurried_typ ty_expected_; + fun_t + in let loc_fun, ty_fun = match in_function with | Some p -> p diff --git a/compiler/syntax/src/jsx_v4.ml b/compiler/syntax/src/jsx_v4.ml index e8fe6defd4..86bbc5ee0f 100644 --- a/compiler/syntax/src/jsx_v4.ml +++ b/compiler/syntax/src/jsx_v4.ml @@ -1028,8 +1028,7 @@ let map_binding ~config ~empty_loc ~pstr_loc ~file_name ~rec_flag binding = in let full_expression = full_expression - |> Ast_uncurried.uncurried_fun ~loc:full_expression.pexp_loc - ~arity:(if has_forward_ref then 2 else 1) + |> Ast_uncurried.uncurried_fun ~arity:(if has_forward_ref then 2 else 1) in let full_expression = match full_module_name with diff --git a/compiler/syntax/src/res_comments_table.ml b/compiler/syntax/src/res_comments_table.ml index ac168be7fb..fc8c104944 100644 --- a/compiler/syntax/src/res_comments_table.ml +++ b/compiler/syntax/src/res_comments_table.ml @@ -1451,8 +1451,6 @@ 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_construct ({txt = Longident.Lident "Function$"}, Some return_expr) -> - walk_expression return_expr t comments | _ -> if is_block_expr return_expr then walk_expression return_expr t comments else diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index 610a37b734..d2ee76e78b 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -528,7 +528,7 @@ let process_underscore_application args = let fun_expr = Ast_helper.Exp.fun_ ~loc ~arity:(Some 1) Nolabel None pattern exp_apply in - Ast_uncurried.uncurried_fun ~loc ~arity:1 fun_expr + Ast_uncurried.uncurried_fun ~arity:1 fun_expr | None -> exp_apply in (args, wrap) @@ -1596,13 +1596,11 @@ and parse_es6_arrow_expression ?(arrow_attrs = []) ?(arrow_start_pos = None) {attrs; label = lbl; expr = default_expr; pat; pos = start_pos} -> let loc = mk_loc start_pos end_pos in let fun_expr = - Ast_helper.Exp.fun_ ~loc ~attrs ~arity:(Some arity) lbl default_expr + Ast_helper.Exp.fun_ ~loc ~attrs ~arity:None lbl default_expr pat expr in if term_param_num = 1 then - ( term_param_num - 1, - Ast_uncurried.uncurried_fun ~loc ~arity fun_expr, - 1 ) + (term_param_num - 1, Ast_uncurried.uncurried_fun ~arity fun_expr, 1) else (term_param_num - 1, fun_expr, arity + 1) | TypeParameter {attrs; locs = newtypes; pos = start_pos} -> ( term_param_num, diff --git a/compiler/syntax/src/res_parens.ml b/compiler/syntax/src/res_parens.ml index cb5a8b0ccc..a4d28ef520 100644 --- a/compiler/syntax/src/res_parens.ml +++ b/compiler/syntax/src/res_parens.ml @@ -111,11 +111,6 @@ let unary_expr_operand expr = Parenthesized | _ when ParsetreeViewer.has_await_attribute expr.pexp_attributes -> Parenthesized - | {pexp_desc = Pexp_construct ({txt = Lident "Function$"}, Some expr)} - when ParsetreeViewer.is_underscore_apply_sugar expr -> - Nothing - | {pexp_desc = Pexp_construct ({txt = Lident "Function$"}, Some _)} -> - Parenthesized | _ -> Nothing) let binary_expr_operand ~is_lhs expr = @@ -183,7 +178,6 @@ let flatten_operand_rhs parent_operator rhs = let prec_parent = ParsetreeViewer.operator_precedence parent_operator in let prec_child = ParsetreeViewer.operator_precedence operator in prec_parent >= prec_child || rhs.pexp_attributes <> [] - | Pexp_construct ({txt = Lident "Function$"}, Some _) -> true | Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}) -> false | Pexp_fun _ when ParsetreeViewer.is_underscore_apply_sugar rhs -> false @@ -279,11 +273,6 @@ let field_expr expr = Parenthesized | _ when ParsetreeViewer.has_await_attribute expr.pexp_attributes -> Parenthesized - | {pexp_desc = Pexp_construct ({txt = Lident "Function$"}, Some expr)} - when ParsetreeViewer.is_underscore_apply_sugar expr -> - Nothing - | {pexp_desc = Pexp_construct ({txt = Lident "Function$"}, Some _)} -> - Parenthesized | _ -> Nothing) let set_field_expr_rhs expr = diff --git a/compiler/syntax/src/res_printer.ml b/compiler/syntax/src/res_printer.ml index 383848802e..9c0328f1be 100644 --- a/compiler/syntax/src/res_printer.ml +++ b/compiler/syntax/src/res_printer.ml @@ -2793,19 +2793,7 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = None, {ppat_desc = Ppat_var {txt = "__x"}}, {pexp_desc = Pexp_apply _}, - _ ) - | Pexp_construct - ( {txt = Lident "Function$"}, - Some - { - pexp_desc = - Pexp_fun - ( Nolabel, - None, - {ppat_desc = Ppat_var {txt = "__x"}}, - {pexp_desc = Pexp_apply _}, - _ ); - } ) -> + _ ) -> (* (__x) => f(a, __x, c) -----> f(a, _, c) *) print_expression_with_comments ~state (ParsetreeViewer.rewrite_underscore_apply e_fun)