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 09cfc1046d..4f4c271d45 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 remove_fun (expr : Parsetree.expression) = 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..3295890137 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -1913,9 +1913,12 @@ let rec approx_type env sty = let rec type_approx env sexp = match sexp.pexp_desc with | Pexp_let (_, _, e) -> type_approx env e - | Pexp_fun (p, _, _, e, _arity) -> + | Pexp_fun (p, _, _, e, arity) -> ( let ty = if is_optional p then type_option (newvar ()) else newvar () in - newty (Tarrow (p, ty, type_approx env e, Cok)) + let t = newty (Tarrow (p, ty, type_approx env e, Cok)) in + match arity with + | None -> t + | Some arity -> Ast_uncurried.make_uncurried_type ~env ~arity t) | Pexp_match (_, {pc_rhs = e} :: _) -> type_approx env e | Pexp_try (e, _) -> type_approx env e | Pexp_tuple l -> newty (Ttuple (List.map (type_approx env) l)) @@ -2525,25 +2528,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 +3257,16 @@ 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 @@ -3311,12 +3304,18 @@ and type_function ?in_function ~arity loc attrs env ty_expected l caselist = Location.prerr_warning case.c_lhs.pat_loc Warnings.Unerasable_optional_argument; let param = name_pattern "param" cases in + let exp_type = instance env (newgenty (Tarrow (l, ty_arg, ty_res, Cok))) in + let exp_type = + match arity with + | None -> exp_type + | Some arity -> Ast_uncurried.make_uncurried_type ~env ~arity exp_type + in re { exp_desc = Texp_function {arg_label = l; arity; param; case; partial}; exp_loc = loc; exp_extra = []; - exp_type = instance env (newgenty (Tarrow (l, ty_arg, ty_res, Cok))); + exp_type; exp_attributes = attrs; exp_env = env; } 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 e99a4ec156..676df152e5 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) @@ -1600,9 +1600,7 @@ and parse_es6_arrow_expression ?(arrow_attrs = []) ?(arrow_start_pos = None) 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,