From b3ce24447d4957697e07ea56e815f22c49d76400 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 17 Jan 2025 10:34:38 +0100 Subject: [PATCH] AST: use inline record for Ptyp_arrow. --- CHANGELOG.md | 1 + analysis/src/SignatureHelp.ml | 3 +- compiler/frontend/ast_compatible.ml | 9 ++-- compiler/frontend/ast_core_type.ml | 18 ++++---- compiler/frontend/ast_core_type_class_type.ml | 2 +- compiler/frontend/ast_external_process.ml | 41 +++++++++--------- compiler/frontend/ast_typ_uncurry.ml | 3 +- compiler/frontend/bs_ast_mapper.ml | 4 +- compiler/ml/ast_helper.ml | 8 ++-- compiler/ml/ast_iterator.ml | 6 +-- compiler/ml/ast_mapper.ml | 4 +- compiler/ml/ast_mapper_from0.ml | 5 +-- compiler/ml/ast_mapper_to0.ml | 4 +- compiler/ml/ast_uncurried.ml | 4 +- compiler/ml/depend.ml | 6 +-- compiler/ml/parsetree.ml | 2 +- compiler/ml/pprintast.ml | 6 +-- compiler/ml/printast.ml | 10 ++--- compiler/ml/typecore.ml | 4 +- compiler/ml/typedecl.ml | 2 +- compiler/ml/typetexp.ml | 8 ++-- compiler/syntax/src/jsx_v4.ml | 42 ++++++++++--------- compiler/syntax/src/res_ast_debugger.ml | 9 +--- compiler/syntax/src/res_comments_table.ml | 29 +++++-------- compiler/syntax/src/res_parsetree_viewer.ml | 29 ++++++------- compiler/syntax/src/res_printer.ml | 2 +- 26 files changed, 123 insertions(+), 138 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 2b6dd4dde9..fa890535b7 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -29,6 +29,7 @@ - AST cleanup: Remove `structure_item_desc.Pstr_class`, `signature_item_desc.Psig_class`, `structure_item_desc.Pstr_class_type`, `signature_item_desc.Psig_class_type`, `structure_item_desc.Tstr_class`, `structure_item_desc.Tstr_class_type`, `signature_item_desc.Tsig_class`, `signature_item_desc.Tsig_class_type` from AST as it is unused. https://github.com/rescript-lang/rescript/pull/7242 - AST cleanup: remove "|." and rename "|." to "->" in the internal representation for the pipe operator. https://github.com/rescript-lang/rescript/pull/7244 - AST cleanup: represent concatenation (`++`) and (dis)equality operators (`==`, `===`, `!=`, `!==`) just like in the syntax. https://github.com/rescript-lang/rescript/pull/7248 +- AST cleanup: use inline record for `Ptyp_arrow`. https://github.com/rescript-lang/rescript/pull/7250 # 12.0.0-alpha.7 diff --git a/analysis/src/SignatureHelp.ml b/analysis/src/SignatureHelp.ml index 42ca312851..0b7b91b5b5 100644 --- a/analysis/src/SignatureHelp.ml +++ b/analysis/src/SignatureHelp.ml @@ -113,7 +113,8 @@ let extractParameters ~signature ~typeStrForParser ~labelPrefixLen = | { (* Gotcha: functions with multiple arugments are modelled as a series of single argument functions. *) Parsetree.ptyp_desc = - Ptyp_arrow (argumentLabel, argumentTypeExpr, nextFunctionExpr, _); + Ptyp_arrow + {lbl = argumentLabel; arg = argumentTypeExpr; ret = nextFunctionExpr}; ptyp_loc; } -> let startOffset = diff --git a/compiler/frontend/ast_compatible.ml b/compiler/frontend/ast_compatible.ml index d4f27fa998..8fb72e457c 100644 --- a/compiler/frontend/ast_compatible.ml +++ b/compiler/frontend/ast_compatible.ml @@ -122,16 +122,17 @@ let apply_labels ?(loc = default_loc) ?(attrs = []) fn }; } -let label_arrow ?(loc = default_loc) ?(attrs = []) ~arity s a b : core_type = +let label_arrow ?(loc = default_loc) ?(attrs = []) ~arity s arg ret : core_type + = { - ptyp_desc = Ptyp_arrow (Asttypes.Labelled s, a, b, arity); + ptyp_desc = Ptyp_arrow {lbl = Labelled s; arg; ret; arity}; ptyp_loc = loc; ptyp_attributes = attrs; } -let opt_arrow ?(loc = default_loc) ?(attrs = []) ~arity s a b : core_type = +let opt_arrow ?(loc = default_loc) ?(attrs = []) ~arity s arg ret : core_type = { - ptyp_desc = Ptyp_arrow (Asttypes.Optional s, a, b, arity); + ptyp_desc = Ptyp_arrow {lbl = Asttypes.Optional s; arg; ret; arity}; ptyp_loc = loc; ptyp_attributes = attrs; } diff --git a/compiler/frontend/ast_core_type.ml b/compiler/frontend/ast_core_type.ml index 3dcd465e1b..a16bf2327a 100644 --- a/compiler/frontend/ast_core_type.ml +++ b/compiler/frontend/ast_core_type.ml @@ -109,7 +109,7 @@ let make_obj ~loc xs = Typ.object_ ~loc xs Closed *) let rec get_uncurry_arity_aux (ty : t) acc = match ty.ptyp_desc with - | Ptyp_arrow (_, _, new_ty, _) -> get_uncurry_arity_aux new_ty (succ acc) + | Ptyp_arrow {ret = new_ty} -> get_uncurry_arity_aux new_ty (succ acc) | Ptyp_poly (_, ty) -> get_uncurry_arity_aux ty acc | _ -> acc @@ -120,12 +120,12 @@ let rec get_uncurry_arity_aux (ty : t) acc = *) let get_uncurry_arity (ty : t) = match ty.ptyp_desc with - | Ptyp_arrow (_, _, rest, _) -> Some (get_uncurry_arity_aux rest 1) + | Ptyp_arrow {ret = rest} -> Some (get_uncurry_arity_aux rest 1) | _ -> None let get_curry_arity (ty : t) = match ty.ptyp_desc with - | Ptyp_arrow (_, _, _, Some arity) -> arity + | Ptyp_arrow {arity = Some arity} -> arity | _ -> get_uncurry_arity_aux ty 0 let is_arity_one ty = get_curry_arity ty = 1 @@ -142,23 +142,23 @@ let mk_fn_type (new_arg_types_ty : param_type list) (result : t) : t = Ext_list.fold_right new_arg_types_ty result (fun {label; ty; attr; loc} acc -> { - ptyp_desc = Ptyp_arrow (label, ty, acc, None); + ptyp_desc = Ptyp_arrow {lbl = label; arg = ty; ret = acc; arity = None}; ptyp_loc = loc; ptyp_attributes = attr; }) in match t.ptyp_desc with - | Ptyp_arrow (l, t1, t2, _arity) -> + | Ptyp_arrow arr -> let arity = List.length new_arg_types_ty in - {t with ptyp_desc = Ptyp_arrow (l, t1, t2, Some arity)} + {t with ptyp_desc = Ptyp_arrow {arr with arity = Some arity}} | _ -> t let list_of_arrow (ty : t) : t * param_type list = let rec aux (ty : t) acc = match ty.ptyp_desc with - | Ptyp_arrow (label, t1, t2, arity) when arity = None || acc = [] -> - aux t2 - (({label; ty = t1; attr = ty.ptyp_attributes; loc = ty.ptyp_loc} + | Ptyp_arrow {lbl = label; arg; ret; arity} when arity = None || acc = [] -> + aux ret + (({label; ty = arg; attr = ty.ptyp_attributes; loc = ty.ptyp_loc} : param_type) :: acc) | Ptyp_poly (_, ty) -> diff --git a/compiler/frontend/ast_core_type_class_type.ml b/compiler/frontend/ast_core_type_class_type.ml index eb55e017cb..5af87136a8 100644 --- a/compiler/frontend/ast_core_type_class_type.ml +++ b/compiler/frontend/ast_core_type_class_type.ml @@ -67,7 +67,7 @@ let default_typ_mapper = Bs_ast_mapper.default_mapper.typ let typ_mapper (self : Bs_ast_mapper.mapper) (ty : Parsetree.core_type) = let loc = ty.ptyp_loc in match ty.ptyp_desc with - | Ptyp_arrow (label, args, body, _) + | Ptyp_arrow {lbl = label; arg = args; ret = body} (* let it go without regard label names, it will report error later when the label is not empty *) -> ( diff --git a/compiler/frontend/ast_external_process.ml b/compiler/frontend/ast_external_process.ml index 54d39e3683..3e73b4fd2c 100644 --- a/compiler/frontend/ast_external_process.ml +++ b/compiler/frontend/ast_external_process.ml @@ -22,9 +22,6 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -[@@@warning "+9"] -(* record pattern match complete checker*) - let rec variant_can_unwrap_aux (row_fields : Parsetree.row_field list) : bool = match row_fields with | [] -> true @@ -68,7 +65,7 @@ let spec_of_ptyp (nolabel : bool) (ptyp : Parsetree.core_type) : | _ -> Bs_syntaxerr.err ptyp.ptyp_loc Invalid_bs_unwrap_type) | `Nothing -> ( match ptyp_desc with - | Ptyp_constr ({txt = Lident "unit"; _}, []) -> + | Ptyp_constr ({txt = Lident "unit"}, []) -> if nolabel then Extern_unit else Nothing | _ -> Nothing) @@ -257,7 +254,7 @@ let parse_external_attributes (no_arguments : bool) (prim_name_check : string) { pstr_desc = Pstr_eval - ({pexp_loc; pexp_desc = Pexp_record (fields, _); _}, _); + ({pexp_loc; pexp_desc = Pexp_record (fields, _)}, _); _; }; ] -> ( @@ -270,10 +267,10 @@ let parse_external_attributes (no_arguments : bool) (prim_name_check : string) Longident.t Location.loc * Parsetree.expression * bool) -> match (l, exp.pexp_desc) with - | ( {txt = Lident "from"; _}, + | ( {txt = Lident "from"}, Pexp_constant (Pconst_string (s, _)) ) -> from_name := Some s - | {txt = Lident "with"; _}, Pexp_record (fields, _) -> + | {txt = Lident "with"}, Pexp_record (fields, _) -> with_ := Some fields | _ -> ()); match (!from_name, !with_) with @@ -395,7 +392,7 @@ let parse_external_attributes (no_arguments : bool) (prim_name_check : string) | "return" -> ( let actions = Ast_payload.ident_or_record_as_config loc payload in match actions with - | [({txt; _}, None)] -> + | [({txt}, None)] -> {st with return_wrapper = return_wrapper loc txt} | _ -> Bs_syntaxerr.err loc Not_supported_directive_in_bs_return) | _ -> raise_notrace Not_handled_external_attribute @@ -467,7 +464,7 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string) match arg_label with | Nolabel -> ( match ty.ptyp_desc with - | Ptyp_constr ({txt = Lident "unit"; _}, []) -> + | Ptyp_constr ({txt = Lident "unit"}, []) -> ( External_arg_spec.empty_kind Extern_unit, param_type :: arg_types, result_types ) @@ -550,7 +547,7 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string) | Nothing -> let for_sure_not_nested = match ty.ptyp_desc with - | Ptyp_constr ({txt = Lident txt; _}, []) -> + | Ptyp_constr ({txt = Lident txt}, []) -> Ast_core_type.is_builtin_rank0_type txt | _ -> false in @@ -643,7 +640,7 @@ let external_desc_of_non_obj (loc : Location.t) (st : external_desc) else Location.raise_errorf ~loc "Ill defined attribute %@set_index (arity of 3)" - | {set_index = true; _} -> + | {set_index = true} -> Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with %@set_index") | { @@ -669,7 +666,7 @@ let external_desc_of_non_obj (loc : Location.t) (st : external_desc) Location.raise_errorf ~loc "Ill defined attribute %@get_index (arity expected 2 : while %d)" arg_type_specs_length - | {get_index = true; _} -> + | {get_index = true} -> Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with %@get_index") | { @@ -702,7 +699,7 @@ let external_desc_of_non_obj (loc : Location.t) (st : external_desc) Location.raise_errorf ~loc "Incorrect FFI attribute found: (%@new should not carry a payload here)" ) - | {module_as_val = Some _; get_index; val_send; _} -> + | {module_as_val = Some _; get_index; val_send} -> let reason = match (get_index, val_send) with | true, _ -> @@ -770,7 +767,7 @@ let external_desc_of_non_obj (loc : Location.t) (st : external_desc) Js_var {name; external_module_name; scopes} (*FIXME: splice is not supported here *) else Js_call {splice; name; external_module_name; scopes; tagged_template} - | {call_name = Some _; _} -> + | {call_name = Some _} -> Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with %@val") | { @@ -797,7 +794,7 @@ let external_desc_of_non_obj (loc : Location.t) (st : external_desc) ]} *) Js_var {name; external_module_name; scopes} - | {val_name = Some _; _} -> + | {val_name = Some _} -> Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with %@val") | { @@ -855,7 +852,7 @@ let external_desc_of_non_obj (loc : Location.t) (st : external_desc) Location.raise_errorf ~loc "Ill defined attribute %@send(first argument can't be const)" | _ :: _ -> Js_send {splice; name; js_send_scopes = scopes}) - | {val_send = Some _; _} -> + | {val_send = Some _} -> Location.raise_errorf ~loc "You used a FFI attribute that can't be used with %@send" | { @@ -876,7 +873,7 @@ let external_desc_of_non_obj (loc : Location.t) (st : external_desc) tagged_template = _; } -> Js_new {name; external_module_name; splice; scopes} - | {new_name = Some _; _} -> + | {new_name = Some _} -> Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with %@new") | { @@ -901,7 +898,7 @@ let external_desc_of_non_obj (loc : Location.t) (st : external_desc) else Location.raise_errorf ~loc "Ill defined attribute %@set (two args required)" - | {set_name = Some _; _} -> + | {set_name = Some _} -> Location.raise_errorf ~loc "conflict attributes found with %@set" | { get_name = Some {name; source = _}; @@ -925,7 +922,7 @@ let external_desc_of_non_obj (loc : Location.t) (st : external_desc) else Location.raise_errorf ~loc "Ill defined attribute %@get (only one argument)" - | {get_name = Some _; _} -> + | {get_name = Some _} -> Location.raise_errorf ~loc "Attribute found that conflicts with %@get" (** Note that the passed [type_annotation] is already processed by visitor pattern before*) @@ -935,8 +932,8 @@ let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type) let prim_name_with_source = {name = prim_name; source = External} in let type_annotation, build_uncurried_type = match type_annotation with - | {ptyp_desc = Ptyp_arrow (_, _, _, Some _); _} as t -> - ( t, + | {ptyp_desc = Ptyp_arrow {arity = Some _}} -> + ( type_annotation, fun ~arity (x : Parsetree.core_type) -> Ast_uncurried.uncurried_type ~arity x ) | _ -> (type_annotation, fun ~arity:_ x -> x) @@ -978,7 +975,7 @@ let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type) Location.raise_errorf ~loc "%@variadic expect the last type to be an array"; match ty.ptyp_desc with - | Ptyp_constr ({txt = Lident "array"; _}, [_]) -> () + | Ptyp_constr ({txt = Lident "array"}, [_]) -> () | _ -> Location.raise_errorf ~loc "%@variadic expect the last type to be an array")); diff --git a/compiler/frontend/ast_typ_uncurry.ml b/compiler/frontend/ast_typ_uncurry.ml index 0b4f2a8692..0b8656e33c 100644 --- a/compiler/frontend/ast_typ_uncurry.ml +++ b/compiler/frontend/ast_typ_uncurry.ml @@ -61,8 +61,7 @@ let to_uncurry_type loc (mapper : Bs_ast_mapper.mapper) let arity = Ast_core_type.get_uncurry_arity fn_type in let fn_type = match fn_type.ptyp_desc with - | Ptyp_arrow (l, t1, t2, _) -> - {fn_type with ptyp_desc = Ptyp_arrow (l, t1, t2, arity)} + | Ptyp_arrow arr -> {fn_type with ptyp_desc = Ptyp_arrow {arr with arity}} | _ -> assert false in match arity with diff --git a/compiler/frontend/bs_ast_mapper.ml b/compiler/frontend/bs_ast_mapper.ml index dd8ca6cf75..cf45c0ba43 100644 --- a/compiler/frontend/bs_ast_mapper.ml +++ b/compiler/frontend/bs_ast_mapper.ml @@ -101,8 +101,8 @@ module T = struct match desc with | Ptyp_any -> any ~loc ~attrs () | Ptyp_var s -> var ~loc ~attrs s - | Ptyp_arrow (lab, t1, t2, arity) -> - arrow ~loc ~attrs ~arity lab (sub.typ sub t1) (sub.typ sub t2) + | Ptyp_arrow {lbl; arg; ret; arity} -> + arrow ~loc ~attrs ~arity lbl (sub.typ sub arg) (sub.typ sub ret) | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) | Ptyp_constr (lid, tl) -> constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) diff --git a/compiler/ml/ast_helper.ml b/compiler/ml/ast_helper.ml index 4b5d055815..e65a39faa1 100644 --- a/compiler/ml/ast_helper.ml +++ b/compiler/ml/ast_helper.ml @@ -54,8 +54,8 @@ module Typ = struct let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a) - let arrow ?loc ?attrs ~arity a b c = - mk ?loc ?attrs (Ptyp_arrow (a, b, c, arity)) + let arrow ?loc ?attrs ~arity lbl arg ret = + mk ?loc ?attrs (Ptyp_arrow {lbl; arg; ret; arity}) let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a) let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b)) let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b)) @@ -82,8 +82,8 @@ module Typ = struct | Ptyp_var x -> check_variable var_names t.ptyp_loc x; Ptyp_var x - | Ptyp_arrow (label, core_type, core_type', a) -> - Ptyp_arrow (label, loop core_type, loop core_type', a) + | Ptyp_arrow {lbl = label; arg; ret; arity = a} -> + Ptyp_arrow {lbl = label; arg = loop arg; ret = loop ret; arity = a} | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) | Ptyp_constr ({txt = Longident.Lident s}, []) when List.mem s var_names -> diff --git a/compiler/ml/ast_iterator.ml b/compiler/ml/ast_iterator.ml index 8bae0d9154..6e232a5619 100644 --- a/compiler/ml/ast_iterator.ml +++ b/compiler/ml/ast_iterator.ml @@ -96,9 +96,9 @@ module T = struct sub.attributes sub attrs; match desc with | Ptyp_any | Ptyp_var _ -> () - | Ptyp_arrow (_lab, t1, t2, _) -> - sub.typ sub t1; - sub.typ sub t2 + | Ptyp_arrow {arg; ret} -> + sub.typ sub arg; + sub.typ sub ret | Ptyp_tuple tyl -> List.iter (sub.typ sub) tyl | Ptyp_constr (lid, tl) -> iter_loc sub lid; diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index a4d9e5b382..66b06f655e 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -93,8 +93,8 @@ module T = struct match desc with | Ptyp_any -> any ~loc ~attrs () | Ptyp_var s -> var ~loc ~attrs s - | Ptyp_arrow (lab, t1, t2, arity) -> - arrow ~loc ~attrs ~arity lab (sub.typ sub t1) (sub.typ sub t2) + | Ptyp_arrow {lbl; arg; ret; arity} -> + arrow ~loc ~attrs ~arity lbl (sub.typ sub arg) (sub.typ sub ret) | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) | Ptyp_constr (lid, tl) -> constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index ddba26ae88..f36bea1f0d 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -106,8 +106,7 @@ module T = struct constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) in match typ0.ptyp_desc with - | Ptyp_constr - (lid, [({ptyp_desc = Ptyp_arrow (lbl, t1, t2, _)} as fun_t); t_arity]) + | Ptyp_constr (lid, [({ptyp_desc = Ptyp_arrow arr} as fun_t); t_arity]) when lid.txt = Lident "function$" -> let decode_arity_string arity_s = int_of_string @@ -120,7 +119,7 @@ module T = struct | _ -> assert false in let arity = arity_from_type t_arity in - {fun_t with ptyp_desc = Ptyp_arrow (lbl, t1, t2, Some arity)} + {fun_t with ptyp_desc = Ptyp_arrow {arr with arity = Some arity}} | _ -> typ0) | Ptyp_object (l, o) -> object_ ~loc ~attrs (List.map (object_field sub) l) o diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index b3a4857c81..99a84e776e 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -98,8 +98,8 @@ module T = struct match desc with | Ptyp_any -> any ~loc ~attrs () | Ptyp_var s -> var ~loc ~attrs s - | Ptyp_arrow (lab, t1, t2, arity) -> ( - let typ0 = arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) in + | Ptyp_arrow {lbl; arg; ret; arity} -> ( + let typ0 = arrow ~loc ~attrs lbl (sub.typ sub arg) (sub.typ sub ret) in match arity with | None -> typ0 | Some arity -> diff --git a/compiler/ml/ast_uncurried.ml b/compiler/ml/ast_uncurried.ml index 9834af1087..16f0abbfee 100644 --- a/compiler/ml/ast_uncurried.ml +++ b/compiler/ml/ast_uncurried.ml @@ -2,8 +2,8 @@ let uncurried_type ~arity (t_arg : Parsetree.core_type) = match t_arg.ptyp_desc with - | Ptyp_arrow (l, t1, t2, _) -> - {t_arg with ptyp_desc = Ptyp_arrow (l, t1, t2, Some arity)} + | Ptyp_arrow arr -> + {t_arg with ptyp_desc = Ptyp_arrow {arr with arity = Some arity}} | _ -> assert false let uncurried_fun ?(async = false) ~arity fun_expr = diff --git a/compiler/ml/depend.ml b/compiler/ml/depend.ml index be6e3224fc..f33454d448 100644 --- a/compiler/ml/depend.ml +++ b/compiler/ml/depend.ml @@ -105,9 +105,9 @@ let rec add_type bv ty = match ty.ptyp_desc with | Ptyp_any -> () | Ptyp_var _ -> () - | Ptyp_arrow (_, t1, t2, _) -> - add_type bv t1; - add_type bv t2 + | Ptyp_arrow {arg; ret} -> + add_type bv arg; + add_type bv ret | Ptyp_tuple tl -> List.iter (add_type bv) tl | Ptyp_constr (c, tl) -> add bv c; diff --git a/compiler/ml/parsetree.ml b/compiler/ml/parsetree.ml index 0c9beb4bb9..741d585ced 100644 --- a/compiler/ml/parsetree.ml +++ b/compiler/ml/parsetree.ml @@ -76,7 +76,7 @@ and core_type = { and core_type_desc = | Ptyp_any (* _ *) | Ptyp_var of string (* 'a *) - | Ptyp_arrow of arg_label * core_type * core_type * arity + | Ptyp_arrow of {lbl: arg_label; arg: core_type; ret: core_type; arity: arity} (* T1 -> T2 Simple ~l:T1 -> T2 Labelled ?l:T1 -> T2 Optional diff --git a/compiler/ml/pprintast.ml b/compiler/ml/pprintast.ml index d6e4c7f0c2..ca6ae8d64e 100644 --- a/compiler/ml/pprintast.ml +++ b/compiler/ml/pprintast.ml @@ -298,10 +298,10 @@ and core_type ctxt f x = (attributes ctxt) x.ptyp_attributes else match x.ptyp_desc with - | Ptyp_arrow (l, ct1, ct2, a) -> + | Ptyp_arrow {lbl = l; arg; ret; arity} -> pp f "@[<2>%a@;->@;%a%s@]" (* FIXME remove parens later *) - (type_with_label ctxt) (l, ct1) (core_type ctxt) ct2 - (match a with + (type_with_label ctxt) (l, arg) (core_type ctxt) ret + (match arity with | None -> "" | Some n -> " (a:" ^ string_of_int n ^ ")") | Ptyp_alias (ct, s) -> pp f "@[<2>%a@;as@;'%s@]" (core_type1 ctxt) ct s diff --git a/compiler/ml/printast.ml b/compiler/ml/printast.ml index 2469a13256..56d0037d22 100644 --- a/compiler/ml/printast.ml +++ b/compiler/ml/printast.ml @@ -122,16 +122,16 @@ let rec core_type i ppf x = match x.ptyp_desc with | Ptyp_any -> line i ppf "Ptyp_any\n" | Ptyp_var s -> line i ppf "Ptyp_var %s\n" s - | Ptyp_arrow (l, ct1, ct2, a) -> + | Ptyp_arrow {lbl; arg; ret; arity} -> line i ppf "Ptyp_arrow\n"; let () = - match a with + match arity with | None -> () | Some n -> line i ppf "arity = %d\n" n in - arg_label i ppf l; - core_type i ppf ct1; - core_type i ppf ct2 + arg_label i ppf lbl; + core_type i ppf arg; + core_type i ppf ret | Ptyp_tuple l -> line i ppf "Ptyp_tuple\n"; list i core_type ppf l diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index df9b6ddefa..a0e4e42200 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -1878,9 +1878,9 @@ and is_nonexpansive_opt = function let rec approx_type env sty = match sty.ptyp_desc with - | Ptyp_arrow (p, _, sty, a) -> + | Ptyp_arrow {lbl = p; ret = sty; arity} -> let ty1 = if is_optional p then type_option (newvar ()) else newvar () in - newty (Tarrow (p, ty1, approx_type env sty, Cok, a)) + newty (Tarrow (p, ty1, approx_type env sty, Cok, arity)) | Ptyp_tuple args -> newty (Ttuple (List.map (approx_type env) args)) | Ptyp_constr (lid, ctl) -> ( try diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index 2ee75b062a..f9ee124bd9 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -1790,7 +1790,7 @@ let transl_exception env sext = let rec arity_from_arrow_type env core_type ty = match (core_type.ptyp_desc, (Ctype.repr ty).desc) with - | Ptyp_arrow (_, _, ct2, _), Tarrow (_, _, t2, _, _) -> + | Ptyp_arrow {ret = ct2}, Tarrow (_, _, t2, _, _) -> 1 + arity_from_arrow_type env ct2 t2 | Ptyp_arrow _, _ | _, Tarrow _ -> assert false | _ -> 0 diff --git a/compiler/ml/typetexp.ml b/compiler/ml/typetexp.ml index 30ab5cffd0..16117f64bc 100644 --- a/compiler/ml/typetexp.ml +++ b/compiler/ml/typetexp.ml @@ -327,17 +327,17 @@ and transl_type_aux env policy styp = v) in ctyp (Ttyp_var name) ty - | Ptyp_arrow (l, st1, st2, arity) -> + | Ptyp_arrow {lbl; arg = st1; ret = st2; arity} -> let cty1 = transl_type env policy st1 in let cty2 = transl_type env policy st2 in let ty1 = cty1.ctyp_type in let ty1 = - if Btype.is_optional l then + if Btype.is_optional lbl then newty (Tconstr (Predef.path_option, [ty1], ref Mnil)) else ty1 in - let ty = newty (Tarrow (l, ty1, cty2.ctyp_type, Cok, arity)) in - ctyp (Ttyp_arrow (l, cty1, cty2, arity)) ty + let ty = newty (Tarrow (lbl, ty1, cty2.ctyp_type, Cok, arity)) in + ctyp (Ttyp_arrow (lbl, cty1, cty2, arity)) ty | Ptyp_tuple stl -> assert (List.length stl >= 2); let ctys = List.map (transl_type env policy) stl in diff --git a/compiler/syntax/src/jsx_v4.ml b/compiler/syntax/src/jsx_v4.ml index 2423588087..d2a2307508 100644 --- a/compiler/syntax/src/jsx_v4.ml +++ b/compiler/syntax/src/jsx_v4.ml @@ -1305,16 +1305,14 @@ let transform_structure_item ~config item = let rec get_prop_types types ({ptyp_loc; ptyp_desc; ptyp_attributes} as full_type) = match ptyp_desc with - | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest), _) + | Ptyp_arrow {lbl = name; arg; ret = {ptyp_desc = Ptyp_arrow _} as typ2} when is_labelled name || is_optional name -> - get_prop_types - ((name, ptyp_attributes, ptyp_loc, type_) :: types) - rest - | Ptyp_arrow (Nolabel, _type, rest, _) -> get_prop_types types rest - | Ptyp_arrow (name, type_, return_value, _) + get_prop_types ((name, ptyp_attributes, ptyp_loc, arg) :: types) typ2 + | Ptyp_arrow {lbl = Nolabel; ret} -> get_prop_types types ret + | Ptyp_arrow {lbl = name; arg; ret = return_value} when is_labelled name || is_optional name -> ( return_value, - (name, ptyp_attributes, return_value.ptyp_loc, type_) :: types ) + (name, ptyp_attributes, return_value.ptyp_loc, arg) :: types ) | _ -> (full_type, types) in let inner_type, prop_types = get_prop_types [] pval_type in @@ -1409,21 +1407,27 @@ let transform_signature_item ~config item = let rec get_prop_types types ({ptyp_loc; ptyp_desc} as full_type) = match ptyp_desc with | Ptyp_arrow - ( name, - ({ptyp_attributes = attrs} as type_), - ({ptyp_desc = Ptyp_arrow _} as rest), - _ ) - when is_optional name || is_labelled name -> - get_prop_types ((name, attrs, ptyp_loc, type_) :: types) rest + { + lbl; + arg = {ptyp_attributes = attrs} as type_; + ret = {ptyp_desc = Ptyp_arrow _} as rest; + } + when is_optional lbl || is_labelled lbl -> + get_prop_types ((lbl, attrs, ptyp_loc, type_) :: types) rest | Ptyp_arrow - ( Nolabel, - {ptyp_desc = Ptyp_constr ({txt = Lident "unit"}, _)}, - rest, - _ ) -> + { + lbl = Nolabel; + arg = {ptyp_desc = Ptyp_constr ({txt = Lident "unit"}, _)}; + ret = rest; + } -> get_prop_types types rest - | Ptyp_arrow (Nolabel, _type, rest, _) -> get_prop_types types rest + | Ptyp_arrow {lbl = Nolabel; ret = rest} -> get_prop_types types rest | Ptyp_arrow - (name, ({ptyp_attributes = attrs} as type_), return_value, _) + { + lbl = name; + arg = {ptyp_attributes = attrs} as type_; + ret = return_value; + } when is_optional name || is_labelled name -> (return_value, (name, attrs, return_value.ptyp_loc, type_) :: types) | _ -> (full_type, types) diff --git a/compiler/syntax/src/res_ast_debugger.ml b/compiler/syntax/src/res_ast_debugger.ml index caaaaa6bdd..767558b77b 100644 --- a/compiler/syntax/src/res_ast_debugger.ml +++ b/compiler/syntax/src/res_ast_debugger.ml @@ -836,14 +836,9 @@ module SexpAst = struct match typexpr.ptyp_desc with | Ptyp_any -> Sexp.atom "Ptyp_any" | Ptyp_var var -> Sexp.list [Sexp.atom "Ptyp_var"; string var] - | Ptyp_arrow (arg_lbl, typ1, typ2, _) -> + | Ptyp_arrow {lbl; arg; ret} -> Sexp.list - [ - Sexp.atom "Ptyp_arrow"; - arg_label arg_lbl; - core_type typ1; - core_type typ2; - ] + [Sexp.atom "Ptyp_arrow"; arg_label lbl; core_type arg; core_type ret] | Ptyp_tuple types -> Sexp.list [Sexp.atom "Ptyp_tuple"; Sexp.list (map_empty ~f:core_type types)] diff --git a/compiler/syntax/src/res_comments_table.ml b/compiler/syntax/src/res_comments_table.ml index 8db0852cb3..3acd19966a 100644 --- a/compiler/syntax/src/res_comments_table.ml +++ b/compiler/syntax/src/res_comments_table.ml @@ -168,34 +168,27 @@ let arrow_type ct = let rec process attrs_before acc typ = match typ with | { - ptyp_desc = Ptyp_arrow ((Nolabel as lbl), typ1, typ2, _); + ptyp_desc = Ptyp_arrow {lbl = Nolabel as lbl; arg; ret}; ptyp_attributes = []; } -> - let arg = ([], lbl, typ1) in - process attrs_before (arg :: acc) typ2 + let arg = ([], lbl, arg) in + process attrs_before (arg :: acc) ret | { - ptyp_desc = Ptyp_arrow ((Nolabel as lbl), typ1, typ2, _); + ptyp_desc = Ptyp_arrow {lbl = Nolabel as lbl; arg; ret}; ptyp_attributes = [({txt = "bs"}, _)] as attrs; } -> - let arg = (attrs, lbl, typ1) in - process attrs_before (arg :: acc) typ2 - | { - ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2, _); - ptyp_attributes = _attrs; - } as return_type -> + let arg = (attrs, lbl, arg) in + process attrs_before (arg :: acc) ret + | {ptyp_desc = Ptyp_arrow {lbl = Nolabel}} as return_type -> let args = List.rev acc in (attrs_before, args, return_type) - | { - ptyp_desc = Ptyp_arrow (((Labelled _ | Optional _) as lbl), typ1, typ2, _); - ptyp_attributes = attrs; - } -> - let arg = (attrs, lbl, typ1) in - process attrs_before (arg :: acc) typ2 + | {ptyp_desc = Ptyp_arrow {lbl; arg; ret}; ptyp_attributes = attrs} -> + let arg = (attrs, lbl, arg) in + process attrs_before (arg :: acc) ret | typ -> (attrs_before, List.rev acc, typ) in match ct with - | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2, _); ptyp_attributes = attrs} - as typ -> + | {ptyp_desc = Ptyp_arrow {lbl = Nolabel}; ptyp_attributes = attrs} as typ -> process attrs [] {typ with ptyp_attributes = []} | typ -> process [] [] typ diff --git a/compiler/syntax/src/res_parsetree_viewer.ml b/compiler/syntax/src/res_parsetree_viewer.ml index 043a2a1863..565a42f6f8 100644 --- a/compiler/syntax/src/res_parsetree_viewer.ml +++ b/compiler/syntax/src/res_parsetree_viewer.ml @@ -7,30 +7,28 @@ let arrow_type ?(max_arity = max_int) ct = let rec process attrs_before acc typ arity = match typ with | _ when arity < 0 -> (attrs_before, List.rev acc, typ) - | {ptyp_desc = Ptyp_arrow (_, _, _, Some _); ptyp_attributes = []} + | {ptyp_desc = Ptyp_arrow {arity = Some _}; ptyp_attributes = []} when acc <> [] -> (attrs_before, List.rev acc, typ) | { - ptyp_desc = Ptyp_arrow ((Nolabel as lbl), typ1, typ2, _); + ptyp_desc = Ptyp_arrow {lbl = Nolabel as lbl; arg; ret}; ptyp_attributes = []; } -> - let arg = ([], lbl, typ1) in - process attrs_before (arg :: acc) typ2 (arity - 1) + let arg = ([], lbl, arg) in + process attrs_before (arg :: acc) ret (arity - 1) | { - ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2, _); + ptyp_desc = Ptyp_arrow {lbl = Nolabel}; ptyp_attributes = [({txt = "bs"}, _)]; } -> (* stop here, the uncurried attribute always indicates the beginning of an arrow function * e.g. `(. int) => (. int)` instead of `(. int, . int)` *) (attrs_before, List.rev acc, typ) - | { - ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2, _); - ptyp_attributes = _attrs; - } as return_type -> + | {ptyp_desc = Ptyp_arrow {lbl = Nolabel}; ptyp_attributes = _attrs} as + return_type -> let args = List.rev acc in (attrs_before, args, return_type) | { - ptyp_desc = Ptyp_arrow (((Labelled _ | Optional _) as lbl), typ1, typ2, _); + ptyp_desc = Ptyp_arrow {lbl = (Labelled _ | Optional _) as lbl; arg; ret}; ptyp_attributes = attrs; } -> (* Res_core.parse_es6_arrow_type has a workaround that removed an extra arity for the function if the @@ -39,21 +37,18 @@ let arrow_type ?(max_arity = max_int) ct = When this case is encountered we add that missing arity so the arrow is printed properly. *) let arity = - match typ1 with + match arg with | {ptyp_desc = Ptyp_any; ptyp_attributes = attrs1} when has_as_attr attrs1 -> arity | _ -> arity - 1 in - let arg = (attrs, lbl, typ1) in - process attrs_before (arg :: acc) typ2 arity + let arg = (attrs, lbl, arg) in + process attrs_before (arg :: acc) ret arity | typ -> (attrs_before, List.rev acc, typ) in match ct with - | { - ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2, _); - ptyp_attributes = attrs1; - } as typ -> + | {ptyp_desc = Ptyp_arrow {lbl = Nolabel}; ptyp_attributes = attrs1} as typ -> process attrs1 [] {typ with ptyp_attributes = []} max_arity | typ -> process [] [] typ max_arity diff --git a/compiler/syntax/src/res_printer.ml b/compiler/syntax/src/res_printer.ml index 3aee2aa5a7..1f48309c24 100644 --- a/compiler/syntax/src/res_printer.ml +++ b/compiler/syntax/src/res_printer.ml @@ -1688,7 +1688,7 @@ and print_typ_expr ~(state : State.t) (typ_expr : Parsetree.core_type) cmt_tbl = (* object printings *) | Ptyp_object (fields, open_flag) -> print_object ~state ~inline:false fields open_flag cmt_tbl - | Ptyp_arrow (_, _, _, arity) -> print_arrow ~arity typ_expr + | Ptyp_arrow {arity} -> print_arrow ~arity typ_expr | Ptyp_constr (longident_loc, [{ptyp_desc = Ptyp_object (fields, open_flag)}]) -> (* for foo<{"a": b}>, when the object is long and needs a line break, we