From 7e9bbc6c4f34a57302d7c61b5655c11d8de34afb Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sat, 21 Dec 2024 09:33:00 +0100 Subject: [PATCH] More ast_uncurried cleanup. --- compiler/frontend/ast_derive_js_mapper.ml | 7 ++----- compiler/frontend/ast_derive_projector.ml | 15 ++++++++------- compiler/ml/ast_uncurried.ml | 21 --------------------- compiler/ml/ctype.ml | 5 +++++ compiler/ml/ctype.mli | 2 ++ compiler/ml/translcore.ml | 5 +---- compiler/ml/typecore.ml | 4 +--- compiler/ml/typedecl.ml | 2 +- compiler/syntax/src/res_core.ml | 16 +++++----------- 9 files changed, 25 insertions(+), 52 deletions(-) diff --git a/compiler/frontend/ast_derive_js_mapper.ml b/compiler/frontend/ast_derive_js_mapper.ml index 7336fcc0db..dfd2694dbb 100644 --- a/compiler/frontend/ast_derive_js_mapper.ml +++ b/compiler/frontend/ast_derive_js_mapper.ml @@ -129,9 +129,7 @@ let app1 = Ast_compatible.app1 let app2 = Ast_compatible.app2 -let ( ->~ ) a b = - Ast_uncurried.uncurried_type ~arity:1 - (Ast_compatible.arrow ~arity:(Some 1) a b) +let ( ->~ ) a b = Ast_compatible.arrow ~arity:(Some 1) a b let raise_when_not_found_ident = Longident.Ldot (Lident Primitive_modules.util, "raiseWhenNotFound") @@ -295,8 +293,7 @@ let init () = let pat_from_js = {Asttypes.loc; txt = from_js} in let to_js_type result = Ast_comb.single_non_rec_val pat_to_js - (Ast_uncurried.uncurried_type ~arity:1 - (Ast_compatible.arrow ~arity:(Some 1) core_type result)) + (Ast_compatible.arrow ~arity:(Some 1) core_type result) in let new_type, new_tdcl = U.new_type_of_type_declaration tdcl ("abs_" ^ name) diff --git a/compiler/frontend/ast_derive_projector.ml b/compiler/frontend/ast_derive_projector.ml index 26c94a51ca..8f36bc576b 100644 --- a/compiler/frontend/ast_derive_projector.ml +++ b/compiler/frontend/ast_derive_projector.ml @@ -120,9 +120,6 @@ let init () = Ext_list.flat_map tdcls handle_tdcl); signature_gen = (fun (tdcls : Parsetree.type_declaration list) _explict_nonrec -> - let handle_uncurried_type_tranform ~arity t = - if arity > 0 then Ast_uncurried.uncurried_type ~arity t else t - in let handle_tdcl tdcl = let core_type = Ast_derive_util.core_type_of_type_declaration tdcl @@ -139,9 +136,9 @@ let init () = | Ptype_record label_declarations -> Ext_list.map label_declarations (fun {pld_name; pld_type} -> Ast_comb.single_non_rec_val ?attrs:gentype_attrs pld_name - (Ast_compatible.arrow ~arity:None core_type pld_type - (*arity will alwys be 1 since these are single param functions*) - |> handle_uncurried_type_tranform ~arity:1)) + (Ast_compatible.arrow ~arity:(Some 1) core_type + pld_type + (*arity will alwys be 1 since these are single param functions*))) | Ptype_variant constructor_declarations -> Ext_list.map constructor_declarations (fun @@ -164,11 +161,15 @@ let init () = | Some x -> x | None -> core_type in + let add_arity ~arity t = + if arity > 0 then Ast_uncurried.uncurried_type ~arity t + else t + in Ast_comb.single_non_rec_val ?attrs:gentype_attrs {loc; txt = Ext_string.uncapitalize_ascii con_name} (Ext_list.fold_right pcd_args annotate_type (fun x acc -> Ast_compatible.arrow ~arity:None x acc) - |> handle_uncurried_type_tranform ~arity)) + |> add_arity ~arity)) | Ptype_open | Ptype_abstract -> 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 179331cfea..ae1b82696e 100644 --- a/compiler/ml/ast_uncurried.ml +++ b/compiler/ml/ast_uncurried.ml @@ -24,24 +24,3 @@ let expr_extract_uncurried_fun (expr : Parsetree.expression) = match expr.pexp_desc with | Pexp_fun (_, _, _, _, Some _) -> expr | _ -> assert false - -(* Typed AST *) - -let tarrow_to_arity (t_arity : Types.type_expr) = - match (Ctype.repr t_arity).desc with - | Tarrow (_, _, _, _, Some arity) -> arity - | Tarrow _ -> assert false - | _ -> - Format.eprintf "t: %a@." Printtyp.raw_type_expr t_arity; - assert false - -let tarrow_to_arity_opt (t_arity : Types.type_expr) = - match (Ctype.repr t_arity).desc with - | Tarrow (_, _, _, _, arity) -> arity - | _ -> None - -let uncurried_type_get_arity ~env typ = - tarrow_to_arity (Ctype.expand_head env typ) - -let uncurried_type_get_arity_opt ~env typ = - tarrow_to_arity_opt (Ctype.expand_head env typ) diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index 88c78b7a13..9605e37279 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -4280,3 +4280,8 @@ let maybe_pointer_type env typ = | _ -> false) row.row_fields | _ -> true + +let get_arity env typ = + match (expand_head env typ).desc with + | Tarrow (_, _, _, _, arity) -> arity + | _ -> None diff --git a/compiler/ml/ctype.mli b/compiler/ml/ctype.mli index 207b54b6db..d7d3a1bc4f 100644 --- a/compiler/ml/ctype.mli +++ b/compiler/ml/ctype.mli @@ -324,3 +324,5 @@ val package_subtype : val variant_is_subtype : (Env.t -> Types.row_desc -> Types.type_expr -> bool) ref + +val get_arity : Env.t -> type_expr -> int option diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 091ca50891..1f34b5fde9 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -770,10 +770,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = Ext_list.exists e.exp_attributes (fun ({txt}, _) -> txt = "res.partial") in if uncurried_partial_app then - let arity_opt = - Ast_uncurried.uncurried_type_get_arity_opt ~env:funct.exp_env - funct.exp_type - in + let arity_opt = Ctype.get_arity funct.exp_env funct.exp_type in match arity_opt with | Some arity -> let real_args = List.filter (fun (_, x) -> Option.is_some x) oargs in diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 882bbf410a..6f42d5597d 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -3521,9 +3521,7 @@ and type_application ?type_clash_context total_app env funct (sargs : sargs) : in let force_uncurried_type funct = if force_tvar then () - else if - Ast_uncurried.uncurried_type_get_arity_opt ~env funct.exp_type = None - then + else if Ctype.get_arity env funct.exp_type = None then raise (Error ( funct.exp_loc, diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index ccbf14a6a7..2ee75b062a 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -1796,7 +1796,7 @@ let rec arity_from_arrow_type env core_type ty = | _ -> 0 let parse_arity env core_type ty = - match Ast_uncurried.uncurried_type_get_arity_opt ~env ty with + match Ctype.get_arity env ty with | Some arity -> let from_constructor = match ty.desc with diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index 80a2ce2dde..02c660b9d3 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -4071,10 +4071,8 @@ and parse_poly_type_expr p = let typ = Ast_helper.Typ.var ~loc:var.loc var.txt in let return_type = parse_typ_expr ~alias:false p in let loc = mk_loc typ.Parsetree.ptyp_loc.loc_start p.prev_end_pos in - let t_fun = - Ast_helper.Typ.arrow ~loc ~arity:None Asttypes.Nolabel typ return_type - in - Ast_uncurried.uncurried_type ~arity:1 t_fun + Ast_helper.Typ.arrow ~loc ~arity:(Some 1) Asttypes.Nolabel typ + return_type | _ -> Ast_helper.Typ.var ~loc:var.loc var.txt) | _ -> assert false) | _ -> parse_typ_expr p @@ -4486,10 +4484,7 @@ and parse_arrow_type_rest ~es6_arrow ~start_pos typ p = Parser.next p; let return_type = parse_typ_expr ~alias:false p in let loc = mk_loc start_pos p.prev_end_pos in - let arrow_typ = - Ast_helper.Typ.arrow ~loc ~arity:None Asttypes.Nolabel typ return_type - in - Ast_uncurried.uncurried_type ~arity:1 arrow_typ + Ast_helper.Typ.arrow ~loc ~arity:(Some 1) Asttypes.Nolabel typ return_type | _ -> typ and parse_typ_expr_region p = @@ -5096,10 +5091,9 @@ and parse_type_equation_or_constr_decl p = let return_type = parse_typ_expr ~alias:false p in let loc = mk_loc uident_start_pos p.prev_end_pos in let arrow_type = - Ast_helper.Typ.arrow ~loc ~arity:None Asttypes.Nolabel typ return_type + Ast_helper.Typ.arrow ~loc ~arity:(Some 1) Asttypes.Nolabel typ + return_type in - let arrow_type = Ast_uncurried.uncurried_type ~arity:1 arrow_type in - let typ = parse_type_alias p arrow_type in (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) | _ -> (Some typ, Asttypes.Public, Parsetree.Ptype_abstract))