From 65b1c681034ef27f324692a6bb0ae40119f54fb4 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 18 Dec 2024 12:27:38 +0100 Subject: [PATCH 1/9] merge conflict --- compiler/syntax/src/jsx_v4.ml | 5 +---- .../expected/react_component_with_props.res.expected | 8 ++++---- 2 files changed, 5 insertions(+), 8 deletions(-) diff --git a/compiler/syntax/src/jsx_v4.ml b/compiler/syntax/src/jsx_v4.ml index aed65e69f39..b1a0b2602e0 100644 --- a/compiler/syntax/src/jsx_v4.ml +++ b/compiler/syntax/src/jsx_v4.ml @@ -1267,10 +1267,7 @@ let map_binding ~config ~empty_loc ~pstr_loc ~file_name ~rec_flag binding = [(Nolabel, Exp.ident {txt = Lident "props"; loc})])) in - let wrapper_expr = - Ast_uncurried.uncurried_fun ~loc:wrapper_expr.pexp_loc ~arity:1 - wrapper_expr - in + let wrapper_expr = Ast_uncurried.uncurried_fun ~arity:1 wrapper_expr in let internal_expression = Exp.let_ Nonrecursive diff --git a/tests/build_tests/super_errors/expected/react_component_with_props.res.expected b/tests/build_tests/super_errors/expected/react_component_with_props.res.expected index 66083eef220..c92961ce8c0 100644 --- a/tests/build_tests/super_errors/expected/react_component_with_props.res.expected +++ b/tests/build_tests/super_errors/expected/react_component_with_props.res.expected @@ -1,11 +1,11 @@ We've found a bug for you! - /.../fixtures/react_component_with_props.res:4:5-13:10 + /.../fixtures/react_component_with_props.res:3:31-13:10 + 1 │ module V4C7 = { 2 │ @react.componentWithProps - 3 │ let make = React.forwardRef(( - 4 │ ~className=?, - 5 │  ~children, + 3 │ let make = React.forwardRef(( + 4 │  ~className=?, . │ ... 12 │  children 13 │   From 2493959f029fd6da98481bd02f142b07325659ae Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Thu, 5 Dec 2024 17:36:47 +0100 Subject: [PATCH 2/9] AST: test storing arity in function type --- analysis/src/SignatureHelp.ml | 2 +- compiler/frontend/ast_compatible.ml | 4 ++-- compiler/frontend/ast_core_type.ml | 8 ++++---- compiler/frontend/ast_core_type_class_type.ml | 4 ++-- compiler/frontend/bs_ast_mapper.ml | 2 +- compiler/gentype/TranslateCoreType.ml | 6 +++--- compiler/ml/ast_helper.ml | 7 ++++--- compiler/ml/ast_helper.mli | 8 +++++++- compiler/ml/ast_iterator.ml | 2 +- compiler/ml/ast_mapper.ml | 2 +- compiler/ml/ast_mapper_from0.ml | 16 +++++++++++++-- compiler/ml/ast_mapper_to0.ml | 2 +- compiler/ml/ast_uncurried.ml | 8 +++++++- compiler/ml/asttypes.ml | 2 ++ compiler/ml/depend.ml | 2 +- compiler/ml/parsetree.ml | 2 +- compiler/ml/pprintast.ml | 6 +++--- compiler/ml/printast.ml | 7 ++++++- compiler/ml/printtyped.ml | 2 +- compiler/ml/tast_iterator.ml | 2 +- compiler/ml/tast_mapper.ml | 4 ++-- compiler/ml/typecore.ml | 2 +- compiler/ml/typedecl.ml | 2 +- compiler/ml/typedtree.ml | 2 +- compiler/ml/typedtree.mli | 2 +- compiler/ml/typedtreeIter.ml | 2 +- compiler/ml/typetexp.ml | 4 ++-- compiler/syntax/src/jsx_v4.ml | 20 +++++++++++-------- compiler/syntax/src/res_ast_debugger.ml | 2 +- compiler/syntax/src/res_comments_table.ml | 16 ++++++++------- compiler/syntax/src/res_parsetree_viewer.ml | 18 ++++++++++------- .../other/expected/regionMissingComma.res.txt | 2 +- .../structure/expected/external.res.txt | 2 +- .../typeDef/expected/namedParameters.res.txt | 2 +- .../typeDef/expected/typeParams.res.txt | 8 ++++---- .../errors/typexpr/expected/arrow.res.txt | 5 +++-- .../typexpr/expected/bsObjSugar.res.txt | 2 +- .../errors/typexpr/expected/garbage.res.txt | 4 ++-- .../expected/nonRecTypes.res.txt | 20 +++++++++++-------- .../pattern/expected/constrained.res.txt | 3 ++- tests/tools_tests/ppx/TestPpx.res | 4 ++++ .../src/expected/TestPpx.res.jsout | 2 ++ 42 files changed, 138 insertions(+), 84 deletions(-) diff --git a/analysis/src/SignatureHelp.ml b/analysis/src/SignatureHelp.ml index 8d97c1b096c..85f6f8fbe78 100644 --- a/analysis/src/SignatureHelp.ml +++ b/analysis/src/SignatureHelp.ml @@ -128,7 +128,7 @@ 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 (argumentLabel, argumentTypeExpr, nextFunctionExpr, _); ptyp_loc; } -> let startOffset = diff --git a/compiler/frontend/ast_compatible.ml b/compiler/frontend/ast_compatible.ml index 94170e4e40e..21e5c8d3ab3 100644 --- a/compiler/frontend/ast_compatible.ml +++ b/compiler/frontend/ast_compatible.ml @@ -96,14 +96,14 @@ let apply_labels ?(loc = default_loc) ?(attrs = []) fn let label_arrow ?(loc = default_loc) ?(attrs = []) s a b : core_type = { - ptyp_desc = Ptyp_arrow (Asttypes.Labelled s, a, b); + ptyp_desc = Ptyp_arrow (Asttypes.Labelled s, a, b, None); ptyp_loc = loc; ptyp_attributes = attrs; } let opt_arrow ?(loc = default_loc) ?(attrs = []) s a b : core_type = { - ptyp_desc = Ptyp_arrow (Asttypes.Optional s, a, b); + ptyp_desc = Ptyp_arrow (Asttypes.Optional s, a, b, None); ptyp_loc = loc; ptyp_attributes = attrs; } diff --git a/compiler/frontend/ast_core_type.ml b/compiler/frontend/ast_core_type.ml index 77629254874..d032a3aed6d 100644 --- a/compiler/frontend/ast_core_type.ml +++ b/compiler/frontend/ast_core_type.ml @@ -108,7 +108,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 (_, _, new_ty, _) -> get_uncurry_arity_aux new_ty (succ acc) | Ptyp_poly (_, ty) -> get_uncurry_arity_aux ty acc | _ -> acc @@ -119,7 +119,7 @@ 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 (_, _, rest, _) -> Some (get_uncurry_arity_aux rest 1) | _ -> None let get_curry_arity (ty : t) = @@ -139,7 +139,7 @@ type param_type = { 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); + ptyp_desc = Ptyp_arrow (label, ty, acc, None); ptyp_loc = loc; ptyp_attributes = attr; }) @@ -147,7 +147,7 @@ let mk_fn_type (new_arg_types_ty : param_type list) (result : t) : 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) -> + | Ptyp_arrow (label, t1, t2, _) -> aux t2 (({label; ty = t1; attr = ty.ptyp_attributes; loc = ty.ptyp_loc} : param_type) diff --git a/compiler/frontend/ast_core_type_class_type.ml b/compiler/frontend/ast_core_type_class_type.ml index 43df6db1791..5b2920a8a7e 100644 --- a/compiler/frontend/ast_core_type_class_type.ml +++ b/compiler/frontend/ast_core_type_class_type.ml @@ -69,11 +69,11 @@ let typ_mapper (self : Bs_ast_mapper.mapper) (ty : Parsetree.core_type) = | { ptyp_attributes; ptyp_desc = - ( Ptyp_arrow (label, args, body) + ( Ptyp_arrow (label, args, body, _) | Ptyp_constr (* function$<...> is re-wrapped around only in case Nothing below *) ( {txt = Lident "function$"}, - [{ptyp_desc = Ptyp_arrow (label, args, body)}; _] ) ); + [{ptyp_desc = Ptyp_arrow (label, args, body, _)}; _] ) ); (* let it go without regard label names, it will report error later when the label is not empty *) diff --git a/compiler/frontend/bs_ast_mapper.ml b/compiler/frontend/bs_ast_mapper.ml index 78adb57b4ce..f254386bc36 100644 --- a/compiler/frontend/bs_ast_mapper.ml +++ b/compiler/frontend/bs_ast_mapper.ml @@ -101,7 +101,7 @@ module T = struct match desc with | Ptyp_any -> any ~loc ~attrs () | Ptyp_var s -> var ~loc ~attrs s - | Ptyp_arrow (lab, t1, t2) -> + | Ptyp_arrow (lab, t1, t2, _) -> arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) | Ptyp_constr (lid, tl) -> diff --git a/compiler/gentype/TranslateCoreType.ml b/compiler/gentype/TranslateCoreType.ml index e6ec268ce69..5ade1f08b8c 100644 --- a/compiler/gentype/TranslateCoreType.ml +++ b/compiler/gentype/TranslateCoreType.ml @@ -52,7 +52,7 @@ let rec translate_arrow_type ~config ~type_vars_gen ~no_function_return_dependencies ~type_env ~rev_arg_deps ~rev_args (core_type : Typedtree.core_type) = match core_type.ctyp_desc with - | Ttyp_arrow (Nolabel, core_type1, core_type2) -> + | Ttyp_arrow (Nolabel, core_type1, core_type2, _) -> let {dependencies; type_} = core_type1 |> fun __x -> translateCoreType_ ~config ~type_vars_gen ~type_env __x @@ -62,8 +62,8 @@ let rec translate_arrow_type ~config ~type_vars_gen |> translate_arrow_type ~config ~type_vars_gen ~no_function_return_dependencies ~type_env ~rev_arg_deps:next_rev_deps ~rev_args:((Nolabel, type_) :: rev_args) - | Ttyp_arrow (((Labelled lbl | Optional lbl) as label), core_type1, core_type2) - -> ( + | Ttyp_arrow + (((Labelled lbl | Optional lbl) as label), core_type1, core_type2, _) -> ( let as_label = match core_type.ctyp_attributes |> Annotation.get_gentype_as_renaming with | Some s -> s diff --git a/compiler/ml/ast_helper.ml b/compiler/ml/ast_helper.ml index 21bb38554ff..d9024fa93ad 100644 --- a/compiler/ml/ast_helper.ml +++ b/compiler/ml/ast_helper.ml @@ -54,7 +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 a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c)) + let arrow ?loc ?attrs ?arity a b c = + mk ?loc ?attrs (Ptyp_arrow (a, b, c, 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)) @@ -81,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') -> - Ptyp_arrow (label, loop core_type, loop core_type') + | Ptyp_arrow (label, core_type, core_type', a) -> + Ptyp_arrow (label, loop core_type, loop core_type', 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_helper.mli b/compiler/ml/ast_helper.mli index 62ee9276a3e..08c15fb846e 100644 --- a/compiler/ml/ast_helper.mli +++ b/compiler/ml/ast_helper.mli @@ -55,7 +55,13 @@ module Typ : sig val any : ?loc:loc -> ?attrs:attrs -> unit -> core_type val var : ?loc:loc -> ?attrs:attrs -> string -> core_type val arrow : - ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type -> core_type + ?loc:loc -> + ?attrs:attrs -> + ?arity:int -> + arg_label -> + core_type -> + core_type -> + core_type val tuple : ?loc:loc -> ?attrs:attrs -> core_type list -> core_type val constr : ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type val object_ : diff --git a/compiler/ml/ast_iterator.ml b/compiler/ml/ast_iterator.ml index 8f64d484c80..bc1c5f8ee91 100644 --- a/compiler/ml/ast_iterator.ml +++ b/compiler/ml/ast_iterator.ml @@ -96,7 +96,7 @@ module T = struct sub.attributes sub attrs; match desc with | Ptyp_any | Ptyp_var _ -> () - | Ptyp_arrow (_lab, t1, t2) -> + | Ptyp_arrow (_lab, t1, t2, _) -> sub.typ sub t1; sub.typ sub t2 | Ptyp_tuple tyl -> List.iter (sub.typ sub) tyl diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index 383e9a47bd6..b731e000e2b 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -93,7 +93,7 @@ module T = struct match desc with | Ptyp_any -> any ~loc ~attrs () | Ptyp_var s -> var ~loc ~attrs s - | Ptyp_arrow (lab, t1, t2) -> + | Ptyp_arrow (lab, t1, t2, _) -> arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) | Ptyp_constr (lid, tl) -> diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index 22934888cad..e94a8f742f3 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -101,8 +101,20 @@ module T = struct | Ptyp_arrow (lab, t1, t2) -> arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) | 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) + | Ptyp_constr (lid, tl) -> ( + let typ0 = + 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]) + when lid.txt = Lident "function$" -> + let arity = Ast_uncurried.arity_from_type t_arity in + let fun_t = + {fun_t with ptyp_desc = Ptyp_arrow (lbl, t1, t2, Some arity)} + in + {typ0 with ptyp_desc = Ptyp_constr (lid, [fun_t; t_arity])} + | _ -> typ0) | Ptyp_object (l, o) -> object_ ~loc ~attrs (List.map (object_field sub) l) o | Ptyp_class () -> assert false diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index 30b08347358..8ad09b1f40d 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -98,7 +98,7 @@ module T = struct match desc with | Ptyp_any -> any ~loc ~attrs () | Ptyp_var s -> var ~loc ~attrs s - | Ptyp_arrow (lab, t1, t2) -> + | Ptyp_arrow (lab, t1, t2, _) -> arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) | Ptyp_constr (lid, tl) -> diff --git a/compiler/ml/ast_uncurried.ml b/compiler/ml/ast_uncurried.ml index 9305d67d884..e1220f80c5d 100644 --- a/compiler/ml/ast_uncurried.ml +++ b/compiler/ml/ast_uncurried.ml @@ -15,7 +15,13 @@ let arity_from_type (typ : Parsetree.core_type) = | Ptyp_variant ([Rtag ({txt}, _, _, _)], _, _) -> decode_arity_string txt | _ -> assert false -let uncurried_type ~loc ~arity t_arg = +let uncurried_type ~loc ~arity (t_arg : Parsetree.core_type) = + let t_arg = + match t_arg.ptyp_desc with + | Ptyp_arrow (l, t1, t2, _) -> + {t_arg with ptyp_desc = Ptyp_arrow (l, t1, t2, Some arity)} + | _ -> assert false + in let t_arity = arity_type ~loc arity in Ast_helper.Typ.constr ~loc {txt = Lident "function$"; loc} [t_arg; t_arity] diff --git a/compiler/ml/asttypes.ml b/compiler/ml/asttypes.ml index 174d3aa7938..cd5379cb8ed 100644 --- a/compiler/ml/asttypes.ml +++ b/compiler/ml/asttypes.ml @@ -46,6 +46,8 @@ type arg_label = | Labelled of string (* label:T -> ... *) | Optional of string (* ?label:T -> ... *) +type arity = int option + type 'a loc = 'a Location.loc = {txt: 'a; loc: Location.t} type variance = Covariant | Contravariant | Invariant diff --git a/compiler/ml/depend.ml b/compiler/ml/depend.ml index 7d48262a792..8ff2961d680 100644 --- a/compiler/ml/depend.ml +++ b/compiler/ml/depend.ml @@ -105,7 +105,7 @@ let rec add_type bv ty = match ty.ptyp_desc with | Ptyp_any -> () | Ptyp_var _ -> () - | Ptyp_arrow (_, t1, t2) -> + | Ptyp_arrow (_, t1, t2, _) -> add_type bv t1; add_type bv t2 | Ptyp_tuple tl -> List.iter (add_type bv) tl diff --git a/compiler/ml/parsetree.ml b/compiler/ml/parsetree.ml index de6c4f0eec3..7ee86f3d170 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 + | Ptyp_arrow of arg_label * core_type * core_type * 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 f78c40db9b6..e13bdb57665 100644 --- a/compiler/ml/pprintast.ml +++ b/compiler/ml/pprintast.ml @@ -247,9 +247,9 @@ and core_type ctxt f x = (attributes ctxt) x.ptyp_attributes end else match x.ptyp_desc with - | Ptyp_arrow (l, ct1, ct2) -> - pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) - (type_with_label ctxt) (l,ct1) (core_type ctxt) ct2 + | Ptyp_arrow (l, ct1, ct2, a) -> + pp f "@[<2>%a@;->@;%a%s@]" (* FIXME remove parens later *) + (type_with_label ctxt) (l,ct1) (core_type ctxt) ct2 (match a with | None -> "" | Some n -> " (a:" ^ string_of_int n ^ ")") | Ptyp_alias (ct, s) -> pp f "@[<2>%a@;as@;'%s@]" (core_type1 ctxt) ct s | Ptyp_poly ([], ct) -> diff --git a/compiler/ml/printast.ml b/compiler/ml/printast.ml index 385c88f4fe4..5ba59bfe67f 100644 --- a/compiler/ml/printast.ml +++ b/compiler/ml/printast.ml @@ -122,8 +122,13 @@ 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) -> + | Ptyp_arrow (l, ct1, ct2, a) -> line i ppf "Ptyp_arrow\n"; + let () = + match a 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 diff --git a/compiler/ml/printtyped.ml b/compiler/ml/printtyped.ml index 51ec7868751..af090ac79ce 100644 --- a/compiler/ml/printtyped.ml +++ b/compiler/ml/printtyped.ml @@ -149,7 +149,7 @@ let rec core_type i ppf x = match x.ctyp_desc with | Ttyp_any -> line i ppf "Ttyp_any\n" | Ttyp_var s -> line i ppf "Ttyp_var %s\n" s - | Ttyp_arrow (l, ct1, ct2) -> + | Ttyp_arrow (l, ct1, ct2, _) -> line i ppf "Ttyp_arrow\n"; arg_label i ppf l; core_type i ppf ct1; diff --git a/compiler/ml/tast_iterator.ml b/compiler/ml/tast_iterator.ml index b925d49336a..62167ea3721 100644 --- a/compiler/ml/tast_iterator.ml +++ b/compiler/ml/tast_iterator.ml @@ -295,7 +295,7 @@ let typ sub {ctyp_desc; ctyp_env; _} = match ctyp_desc with | Ttyp_any -> () | Ttyp_var _ -> () - | Ttyp_arrow (_, ct1, ct2) -> + | Ttyp_arrow (_, ct1, ct2, _) -> sub.typ sub ct1; sub.typ sub ct2 | Ttyp_tuple list -> List.iter (sub.typ sub) list diff --git a/compiler/ml/tast_mapper.ml b/compiler/ml/tast_mapper.ml index 7a60dcf4495..bce2002a354 100644 --- a/compiler/ml/tast_mapper.ml +++ b/compiler/ml/tast_mapper.ml @@ -362,8 +362,8 @@ let typ sub x = let ctyp_desc = match x.ctyp_desc with | (Ttyp_any | Ttyp_var _) as d -> d - | Ttyp_arrow (label, ct1, ct2) -> - Ttyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2) + | Ttyp_arrow (label, ct1, ct2, arity) -> + Ttyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2, arity) | Ttyp_tuple list -> Ttyp_tuple (List.map (sub.typ sub) list) | Ttyp_constr (path, lid, list) -> Ttyp_constr (path, lid, List.map (sub.typ sub) list) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 8af809c5c88..abc46e0af74 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -1895,7 +1895,7 @@ and is_nonexpansive_opt = function let rec approx_type env sty = match sty.ptyp_desc with - | Ptyp_arrow (p, _, sty) -> + | Ptyp_arrow (p, _, sty, _) -> let ty1 = if is_optional p then type_option (newvar ()) else newvar () in newty (Tarrow (p, ty1, approx_type env sty, Cok)) | Ptyp_tuple args -> newty (Ttuple (List.map (approx_type env) args)) diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index 25af79d1461..719a0cdea7d 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 (_, _, ct2, _), Tarrow (_, _, t2, _) -> 1 + arity_from_arrow_type env ct2 t2 | Ptyp_arrow _, _ | _, Tarrow _ -> assert false | _ -> 0 diff --git a/compiler/ml/typedtree.ml b/compiler/ml/typedtree.ml index 571dc3f4d6c..6d19e74be8d 100644 --- a/compiler/ml/typedtree.ml +++ b/compiler/ml/typedtree.ml @@ -314,7 +314,7 @@ and core_type = { and core_type_desc = | Ttyp_any | Ttyp_var of string - | Ttyp_arrow of arg_label * core_type * core_type + | Ttyp_arrow of arg_label * core_type * core_type * arity | Ttyp_tuple of core_type list | Ttyp_constr of Path.t * Longident.t loc * core_type list | Ttyp_object of object_field list * closed_flag diff --git a/compiler/ml/typedtree.mli b/compiler/ml/typedtree.mli index a0d98445747..fd2eba0024b 100644 --- a/compiler/ml/typedtree.mli +++ b/compiler/ml/typedtree.mli @@ -420,7 +420,7 @@ and core_type = { and core_type_desc = | Ttyp_any | Ttyp_var of string - | Ttyp_arrow of arg_label * core_type * core_type + | Ttyp_arrow of arg_label * core_type * core_type * arity | Ttyp_tuple of core_type list | Ttyp_constr of Path.t * Longident.t loc * core_type list | Ttyp_object of object_field list * closed_flag diff --git a/compiler/ml/typedtreeIter.ml b/compiler/ml/typedtreeIter.ml index 858f7da4cae..74213d65a99 100644 --- a/compiler/ml/typedtreeIter.ml +++ b/compiler/ml/typedtreeIter.ml @@ -383,7 +383,7 @@ end = struct (match ct.ctyp_desc with | Ttyp_any -> () | Ttyp_var _ -> () - | Ttyp_arrow (_label, ct1, ct2) -> + | Ttyp_arrow (_label, ct1, ct2, _) -> iter_core_type ct1; iter_core_type ct2 | Ttyp_tuple list -> List.iter iter_core_type list diff --git a/compiler/ml/typetexp.ml b/compiler/ml/typetexp.ml index cdd561ea6b0..51da4929d6c 100644 --- a/compiler/ml/typetexp.ml +++ b/compiler/ml/typetexp.ml @@ -327,7 +327,7 @@ and transl_type_aux env policy styp = v) in ctyp (Ttyp_var name) ty - | Ptyp_arrow (l, st1, st2) -> + | Ptyp_arrow (l, st1, st2, arity) -> let cty1 = transl_type env policy st1 in let cty2 = transl_type env policy st2 in let ty1 = cty1.ctyp_type in @@ -337,7 +337,7 @@ and transl_type_aux env policy styp = else ty1 in let ty = newty (Tarrow (l, ty1, cty2.ctyp_type, Cok)) in - ctyp (Ttyp_arrow (l, cty1, cty2)) ty + ctyp (Ttyp_arrow (l, 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 b1a0b2602e0..96b43c61eb9 100644 --- a/compiler/syntax/src/jsx_v4.ml +++ b/compiler/syntax/src/jsx_v4.ml @@ -1319,13 +1319,13 @@ 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 (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest), _) 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) + | Ptyp_arrow (Nolabel, _type, rest, _) -> get_prop_types types rest + | Ptyp_arrow (name, type_, return_value, _) when is_labelled name || is_optional name -> ( return_value, (name, ptyp_attributes, return_value.ptyp_loc, type_) :: types ) @@ -1426,15 +1426,19 @@ let transform_signature_item ~config item = | Ptyp_arrow ( name, ({ptyp_attributes = attrs} as type_), - ({ptyp_desc = Ptyp_arrow _} as rest) ) + ({ptyp_desc = Ptyp_arrow _} as rest), + _ ) when is_optional name || is_labelled name -> get_prop_types ((name, attrs, ptyp_loc, type_) :: types) rest | Ptyp_arrow - (Nolabel, {ptyp_desc = Ptyp_constr ({txt = Lident "unit"}, _)}, rest) - -> + ( Nolabel, + {ptyp_desc = Ptyp_constr ({txt = Lident "unit"}, _)}, + rest, + _ ) -> get_prop_types types rest - | Ptyp_arrow (Nolabel, _type, rest) -> get_prop_types types rest - | Ptyp_arrow (name, ({ptyp_attributes = attrs} as type_), return_value) + | Ptyp_arrow (Nolabel, _type, rest, _) -> get_prop_types types rest + | Ptyp_arrow + (name, ({ptyp_attributes = attrs} as type_), 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 5b670076bc6..c43c4c7a3f5 100644 --- a/compiler/syntax/src/res_ast_debugger.ml +++ b/compiler/syntax/src/res_ast_debugger.ml @@ -843,7 +843,7 @@ 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 (arg_lbl, typ1, typ2, _) -> Sexp.list [ Sexp.atom "Ptyp_arrow"; diff --git a/compiler/syntax/src/res_comments_table.ml b/compiler/syntax/src/res_comments_table.ml index fc8c1049449..f2c6fa2ef1d 100644 --- a/compiler/syntax/src/res_comments_table.ml +++ b/compiler/syntax/src/res_comments_table.ml @@ -168,23 +168,25 @@ 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 ((Nolabel as lbl), typ1, typ2, _); ptyp_attributes = []; } -> let arg = ([], lbl, typ1) in process attrs_before (arg :: acc) typ2 | { - ptyp_desc = Ptyp_arrow ((Nolabel as lbl), typ1, typ2); + ptyp_desc = Ptyp_arrow ((Nolabel as lbl), typ1, typ2, _); 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 -> + | { + ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2, _); + 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 (((Labelled _ | Optional _) as lbl), typ1, typ2, _); ptyp_attributes = attrs; } -> let arg = (attrs, lbl, typ1) in @@ -192,8 +194,8 @@ let arrow_type ct = | 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 (Nolabel, _typ1, _typ2, _); 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 5c55feb51ab..1e5aceb1de7 100644 --- a/compiler/syntax/src/res_parsetree_viewer.ml +++ b/compiler/syntax/src/res_parsetree_viewer.ml @@ -8,24 +8,26 @@ let arrow_type ?(arity = max_int) ?(attrs = []) ct = match typ with | typ when arity < 0 -> (attrs_before, List.rev acc, typ) | { - ptyp_desc = Ptyp_arrow ((Nolabel as lbl), typ1, typ2); + ptyp_desc = Ptyp_arrow ((Nolabel as lbl), typ1, typ2, _); ptyp_attributes = []; } -> let arg = ([], lbl, typ1) in process attrs_before (arg :: acc) typ2 (arity - 1) | { - ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); + ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2, _); 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 (Nolabel, _typ1, _typ2, _); + 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 (((Labelled _ | Optional _) as lbl), typ1, typ2, _); ptyp_attributes = attrs; } -> (* Res_core.parse_es6_arrow_type has a workaround that removed an extra arity for the function if the @@ -45,8 +47,10 @@ let arrow_type ?(arity = max_int) ?(attrs = []) ct = | 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 (Nolabel, _typ1, _typ2, _); + ptyp_attributes = attrs1; + } as typ -> let attrs = attrs @ attrs1 in process attrs [] {typ with ptyp_attributes = []} arity | typ -> process attrs [] typ arity diff --git a/tests/syntax_tests/data/parsing/errors/other/expected/regionMissingComma.res.txt b/tests/syntax_tests/data/parsing/errors/other/expected/regionMissingComma.res.txt index 256d94b4fca..5dc59cb7603 100644 --- a/tests/syntax_tests/data/parsing/errors/other/expected/regionMissingComma.res.txt +++ b/tests/syntax_tests/data/parsing/errors/other/expected/regionMissingComma.res.txt @@ -24,7 +24,7 @@ external make : (?style:((ReactDOMRe.Style.t)[@res.namedArgLoc ]) -> - ?image:((bool)[@res.namedArgLoc ]) -> React.element, + ?image:((bool)[@res.namedArgLoc ]) -> React.element (a:2), [ `Has_arity2 ]) function$ = "ModalContent" type nonrec 'extraInfo student = { diff --git a/tests/syntax_tests/data/parsing/errors/structure/expected/external.res.txt b/tests/syntax_tests/data/parsing/errors/structure/expected/external.res.txt index 5885a5454af..220dfdedfff 100644 --- a/tests/syntax_tests/data/parsing/errors/structure/expected/external.res.txt +++ b/tests/syntax_tests/data/parsing/errors/structure/expected/external.res.txt @@ -9,5 +9,5 @@ An external requires the name of the JS value you're referring to, like "setTimeout". external setTimeout : - ((unit -> unit, [ `Has_arity1 ]) function$ -> int -> float, + ((unit -> unit (a:1), [ `Has_arity1 ]) function$ -> int -> float (a:2), [ `Has_arity2 ]) function$ \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/errors/typeDef/expected/namedParameters.res.txt b/tests/syntax_tests/data/parsing/errors/typeDef/expected/namedParameters.res.txt index 8d84646515f..42e30cde3d3 100644 --- a/tests/syntax_tests/data/parsing/errors/typeDef/expected/namedParameters.res.txt +++ b/tests/syntax_tests/data/parsing/errors/typeDef/expected/namedParameters.res.txt @@ -7,4 +7,4 @@ A labeled parameter starts with a `~`. Did you mean: `~stroke`? -type nonrec draw = (stroke:pencil -> unit, [ `Has_arity1 ]) function$ \ No newline at end of file +type nonrec draw = (stroke:pencil -> unit (a:1), [ `Has_arity1 ]) function$ \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/errors/typeDef/expected/typeParams.res.txt b/tests/syntax_tests/data/parsing/errors/typeDef/expected/typeParams.res.txt index dcf769316a3..c67f12b9ca2 100644 --- a/tests/syntax_tests/data/parsing/errors/typeDef/expected/typeParams.res.txt +++ b/tests/syntax_tests/data/parsing/errors/typeDef/expected/typeParams.res.txt @@ -62,16 +62,16 @@ type nonrec 'a node = { type nonrec ('from, 'for) derivedNode = { mutable value: 'to_ ; - updateF: ('from -> 'to_, [ `Has_arity1 ]) function$ } + updateF: ('from -> 'to_ (a:1), [ `Has_arity1 ]) function$ } type nonrec ('from, ') derivedNode = { mutable value: 'to_ ; - updateF: ('from -> 'to_, [ `Has_arity1 ]) function$ } + updateF: ('from -> 'to_ (a:1), [ `Has_arity1 ]) function$ } type nonrec ('from, ') derivedNode = { mutable value: 'to_ ; - updateF: ('from -> 'to_, [ `Has_arity1 ]) function$ } + updateF: ('from -> 'to_ (a:1), [ `Has_arity1 ]) function$ } type nonrec ('from, 'foo) derivedNode = { mutable value: 'to_ ; - updateF: ('from -> 'to_, [ `Has_arity1 ]) function$ } \ No newline at end of file + updateF: ('from -> 'to_ (a:1), [ `Has_arity1 ]) function$ } \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/errors/typexpr/expected/arrow.res.txt b/tests/syntax_tests/data/parsing/errors/typexpr/expected/arrow.res.txt index 5d79132be9c..996672a667f 100644 --- a/tests/syntax_tests/data/parsing/errors/typexpr/expected/arrow.res.txt +++ b/tests/syntax_tests/data/parsing/errors/typexpr/expected/arrow.res.txt @@ -34,14 +34,15 @@ Did you forget a `:` here? It signals the start of a type external add_nat : - (nat -> int, [ `Has_arity1 ]) function$ = "add_nat_bytecode" + (nat -> int (a:1), [ `Has_arity1 ]) function$ = "add_nat_bytecode" module Error2 = struct type nonrec observation = { observed: int ; onStep: - (currentValue:((unit)[@res.namedArgLoc ]) -> [%rescript.typehole ], + (currentValue:((unit)[@res.namedArgLoc ]) -> + [%rescript.typehole ] (a:1), [ `Has_arity1 ]) function$ } end diff --git a/tests/syntax_tests/data/parsing/errors/typexpr/expected/bsObjSugar.res.txt b/tests/syntax_tests/data/parsing/errors/typexpr/expected/bsObjSugar.res.txt index 178e0ee6991..461d3abfa7c 100644 --- a/tests/syntax_tests/data/parsing/errors/typexpr/expected/bsObjSugar.res.txt +++ b/tests/syntax_tests/data/parsing/errors/typexpr/expected/bsObjSugar.res.txt @@ -143,7 +143,7 @@ type nonrec state = type nonrec state = < url: string ;protocols: [%rescript.typehole ] > type nonrec state = < - send: (string -> [%rescript.typehole ], [ `Has_arity1 ]) function$ + send: (string -> [%rescript.typehole ] (a:1), [ `Has_arity1 ]) function$ [@meth ] > type nonrec state = < age: [%rescript.typehole ] ;name: string > type nonrec state = < age: [%rescript.typehole ] [@set ] ;name: string > diff --git a/tests/syntax_tests/data/parsing/errors/typexpr/expected/garbage.res.txt b/tests/syntax_tests/data/parsing/errors/typexpr/expected/garbage.res.txt index a438e0fa7b8..48b592b3b07 100644 --- a/tests/syntax_tests/data/parsing/errors/typexpr/expected/garbage.res.txt +++ b/tests/syntax_tests/data/parsing/errors/typexpr/expected/garbage.res.txt @@ -9,5 +9,5 @@ I'm not sure what to parse here when looking at "?". external printName : - (name:((unit)[@res.namedArgLoc ]) -> unit, [ `Has_arity1 ]) function$ = - "printName"[@@module {js|moduleName|js}] \ No newline at end of file + (name:((unit)[@res.namedArgLoc ]) -> unit (a:1), [ `Has_arity1 ]) function$ + = "printName"[@@module {js|moduleName|js}] \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/infiniteLoops/expected/nonRecTypes.res.txt b/tests/syntax_tests/data/parsing/infiniteLoops/expected/nonRecTypes.res.txt index 9241e845d30..7818d02a437 100644 --- a/tests/syntax_tests/data/parsing/infiniteLoops/expected/nonRecTypes.res.txt +++ b/tests/syntax_tests/data/parsing/infiniteLoops/expected/nonRecTypes.res.txt @@ -89,30 +89,34 @@ include ;;(t value) = {js||js} ;;{js|BS:6.0.1\x84\x95\xa6\xbe\0\0\0#\0\0\0\r\0\0\0&\0\0\0#\x91\xa0\xa0A\xa0$size@\xa0\xa0A\xa0$root@\xa0\xa0A\xa0'compare@@|js} external sizeSet : - ('value t -> int -> unit, [ `Has_arity2 ]) function$ = "size" + ('value t -> int -> unit (a:2), [ `Has_arity2 ]) function$ = "size" ;;{js|BS:6.0.1\x84\x95\xa6\xbe\0\0\0\x15\0\0\0\t\0\0\0\x1a\0\0\0\x19\xb0\xa0\xa0A\x91@\xa0\xa0A\x04\x03@E\x97\xa0$size@|js} ;;[|(({js|use sizeGet instead or use {abstract = light} explicitly|js}) [@ocaml.deprecated ])|] - external size : ('value t -> int, [ `Has_arity1 ]) function$ = "" + external size : + ('value t -> int (a:1), [ `Has_arity1 ]) function$ = "" ;;{js|BS:6.0.1\x84\x95\xa6\xbe\0\0\0\x10\0\0\0\x07\0\0\0\x14\0\0\0\x13\xb0\xa0\xa0A\x91@@A\x98\xa0$size@|js} - external sizeGet : ('value t -> int, [ `Has_arity1 ]) function$ = "" + external sizeGet : + ('value t -> int (a:1), [ `Has_arity1 ]) function$ = "" ;;{js|BS:6.0.1\x84\x95\xa6\xbe\0\0\0\x10\0\0\0\x07\0\0\0\x14\0\0\0\x13\xb0\xa0\xa0A\x91@@A\x98\xa0$size@|js} external rootSet : - ('value t -> 'value node option -> unit, [ `Has_arity2 ]) function$ - = "root" + ('value t -> 'value node option -> unit (a:2), [ `Has_arity2 ]) + function$ = "root" ;;{js|BS:6.0.1\x84\x95\xa6\xbe\0\0\0\x15\0\0\0\t\0\0\0\x1a\0\0\0\x19\xb0\xa0\xa0A\x91@\xa0\xa0A\x04\x03@E\x97\xa0$root@|js} ;;[|(({js|use rootGet instead or use {abstract = light} explicitly|js}) [@ocaml.deprecated ])|] external root : - ('value t -> 'value node option, [ `Has_arity1 ]) function$ = "" + ('value t -> 'value node option (a:1), [ `Has_arity1 ]) function$ = + "" ;;{js|BS:6.0.1\x84\x95\xa6\xbe\0\0\0\x10\0\0\0\x07\0\0\0\x14\0\0\0\x13\xb0\xa0\xa0A\x91@@A\x98\xa0$root@|js} external rootGet : - ('value t -> 'value node option, [ `Has_arity1 ]) function$ = "" + ('value t -> 'value node option (a:1), [ `Has_arity1 ]) function$ = + "" ;;{js|BS:6.0.1\x84\x95\xa6\xbe\0\0\0\x10\0\0\0\x07\0\0\0\x14\0\0\0\x13\xb0\xa0\xa0A\x91@@A\x98\xa0$root@|js} ;;[|(({js|use compareGet instead or use {abstract = light} explicitly|js}) [@ocaml.deprecated ])|] external compare : - ('value t -> [ [%rescript.typehole ]] Js.Internal.fn, + ('value t -> [ [%rescript.typehole ]] Js.Internal.fn (a:1), [ `Has_arity1 ]) function$ ;;(({js|Arity_2('value, 'value)], int) = "" diff --git a/tests/syntax_tests/data/parsing/recovery/pattern/expected/constrained.res.txt b/tests/syntax_tests/data/parsing/recovery/pattern/expected/constrained.res.txt index 2dc285d2047..fd51e85add6 100644 --- a/tests/syntax_tests/data/parsing/recovery/pattern/expected/constrained.res.txt +++ b/tests/syntax_tests/data/parsing/recovery/pattern/expected/constrained.res.txt @@ -11,4 +11,5 @@ Did you forget a `)` here? ;;match x with - | (a : (int -> unit, [ `Has_arity1 ]) function$) -> [%rescript.exprhole ] \ No newline at end of file + | (a : (int -> unit (a:1), [ `Has_arity1 ]) function$) -> + [%rescript.exprhole ] \ No newline at end of file diff --git a/tests/tools_tests/ppx/TestPpx.res b/tests/tools_tests/ppx/TestPpx.res index 88cd500f374..a3288f33e21 100644 --- a/tests/tools_tests/ppx/TestPpx.res +++ b/tests/tools_tests/ppx/TestPpx.res @@ -31,3 +31,7 @@ external useState: (unit => 'state) => string = "useState" let _ = useState(() => 0) let fpromise = async (promise, _x) => await promise +module Uncurried = { + type f1 = int => string + type f2 = (int, int) => string +} diff --git a/tests/tools_tests/src/expected/TestPpx.res.jsout b/tests/tools_tests/src/expected/TestPpx.res.jsout index 653567ba054..819d3cf4ec0 100644 --- a/tests/tools_tests/src/expected/TestPpx.res.jsout +++ b/tests/tools_tests/src/expected/TestPpx.res.jsout @@ -38,6 +38,7 @@ React.useState(() => 0); async function fpromise(promise, _x) { return await promise; } +let Uncurried = {}; let a = "A"; @@ -52,4 +53,5 @@ exports.vv = vv; exports.OptionalFields = OptionalFields; exports.Arity = Arity; exports.fpromise = fpromise; +exports.Uncurried = Uncurried; /* Not a pure module */ From 6fec22969445e8c6ef96deb8cd28dc93b794b079 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 9 Dec 2024 08:22:51 +0100 Subject: [PATCH 3/9] WIP: extend types and type propagation with arity This needs some info from function definition that is not readily available. Better to postpone this until arity is explicit in function definitions. --- analysis/reanalyze/src/DeadOptionalArgs.ml | 8 +- analysis/src/CompletionBackEnd.ml | 2 +- analysis/src/CompletionJsx.ml | 4 +- analysis/src/CreateInterface.ml | 10 +- analysis/src/Shared.ml | 2 +- analysis/src/TypeUtils.ml | 20 +- compiler/frontend/ast_comb.ml | 6 +- compiler/frontend/ast_compatible.ml | 11 +- compiler/frontend/ast_compatible.mli | 9 +- compiler/frontend/ast_core_type.ml | 3 +- compiler/frontend/ast_derive_abstract.ml | 17 +- compiler/frontend/ast_derive_js_mapper.ml | 9 +- compiler/frontend/ast_derive_projector.ml | 4 +- compiler/frontend/ast_exp_handle_external.ml | 20 +- compiler/frontend/ast_external_process.ml | 8 +- compiler/frontend/ast_typ_uncurry.ml | 10 +- compiler/frontend/bs_ast_mapper.ml | 4 +- .../gentype/TranslateTypeExprFromTypes.ml | 5 +- compiler/ml/ast_helper.ml | 2 +- compiler/ml/ast_helper.mli | 2 +- compiler/ml/ast_mapper.ml | 4 +- compiler/ml/ast_mapper_from0.ml | 2 +- compiler/ml/ast_uncurried.ml | 24 ++- compiler/ml/btype.ml | 5 +- compiler/ml/ctype.ml | 24 ++- compiler/ml/printtyp.ml | 6 +- compiler/ml/record_type_spread.ml | 4 +- compiler/ml/translcore.ml | 2 +- compiler/ml/typecore.ml | 56 +++--- compiler/ml/typedecl.ml | 4 +- compiler/ml/typedtree.ml | 5 +- compiler/ml/typedtree.mli | 6 +- compiler/ml/typeopt.ml | 2 +- compiler/ml/types.ml | 2 +- compiler/ml/types.mli | 2 +- compiler/ml/typetexp.ml | 2 +- compiler/syntax/src/res_core.ml | 12 +- .../other/expected/labelledParameters.res.txt | 2 +- .../typeDef/expected/inlineRecord.res.txt | 4 +- .../expected/UncurriedByDefault.res.txt | 188 +++++++++--------- .../expressions/expected/arrow.res.txt | 2 +- .../expressions/expected/block.res.txt | 2 +- .../expected/locallyAbstractTypes.res.txt | 3 +- .../grammar/modexpr/expected/functor.res.txt | 4 +- .../modtype/expected/parenthesized.res.txt | 6 +- .../grammar/modtype/expected/typeof.res.txt | 6 +- .../grammar/modtype/expected/with.res.txt | 7 +- .../signature/expected/external.res.txt | 10 +- .../signature/expected/recModule.res.txt | 4 +- .../expected/externalDefinition.res.txt | 15 +- .../expected/constructorDeclaration.res.txt | 14 +- .../expected/privateTypeEquation.res.txt | 11 +- .../expected/typeInformation.res.txt | 6 +- .../grammar/typexpr/expected/alias.res.txt | 19 +- .../grammar/typexpr/expected/es6Arrow.res.txt | 60 +++--- .../expected/firstClassModules.res.txt | 4 +- .../expected/objectTypeSpreading.res.txt | 8 +- .../typexpr/expected/parenthesized.res.txt | 2 +- .../grammar/typexpr/expected/poly.res.txt | 22 +- .../typexpr/expected/polyVariant.res.txt | 8 +- .../typexpr/expected/uncurried.res.txt | 21 +- .../grammar/typexpr/expected/unit.res.txt | 19 +- tools/src/tools.ml | 2 +- 63 files changed, 434 insertions(+), 333 deletions(-) diff --git a/analysis/reanalyze/src/DeadOptionalArgs.ml b/analysis/reanalyze/src/DeadOptionalArgs.ml index 8a3c7e4b874..4b825a6f2b5 100644 --- a/analysis/reanalyze/src/DeadOptionalArgs.ml +++ b/analysis/reanalyze/src/DeadOptionalArgs.ml @@ -31,8 +31,8 @@ let addFunctionReference ~(locFrom : Location.t) ~(locTo : Location.t) = let rec hasOptionalArgs (texpr : Types.type_expr) = match texpr.desc with | _ when not (active ()) -> false - | Tarrow (Optional _, _tFrom, _tTo, _) -> true - | Tarrow (_, _tFrom, tTo, _) -> hasOptionalArgs tTo + | Tarrow (Optional _, _tFrom, _tTo, _, _) -> true + | Tarrow (_, _tFrom, tTo, _, _) -> hasOptionalArgs tTo | Tlink t -> hasOptionalArgs t | Tsubst t -> hasOptionalArgs t | _ -> false @@ -40,8 +40,8 @@ let rec hasOptionalArgs (texpr : Types.type_expr) = let rec fromTypeExpr (texpr : Types.type_expr) = match texpr.desc with | _ when not (active ()) -> [] - | Tarrow (Optional s, _tFrom, tTo, _) -> s :: fromTypeExpr tTo - | Tarrow (_, _tFrom, tTo, _) -> fromTypeExpr tTo + | Tarrow (Optional s, _tFrom, tTo, _, _) -> s :: fromTypeExpr tTo + | Tarrow (_, _tFrom, tTo, _, _) -> fromTypeExpr tTo | Tlink t -> fromTypeExpr t | Tsubst t -> fromTypeExpr t | _ -> [] diff --git a/analysis/src/CompletionBackEnd.ml b/analysis/src/CompletionBackEnd.ml index b1463ce7d76..870993800cb 100644 --- a/analysis/src/CompletionBackEnd.ml +++ b/analysis/src/CompletionBackEnd.ml @@ -898,7 +898,7 @@ and getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env ~exact | [] -> tRet | (label, tArg) :: rest -> let restType = reconstructFunctionType rest tRet in - {typ with desc = Tarrow (label, tArg, restType, Cok)} + {typ with desc = Tarrow (label, tArg, restType, Cok, None)} in let rec processApply args labels = match (args, labels) with diff --git a/analysis/src/CompletionJsx.ml b/analysis/src/CompletionJsx.ml index 4d68ad30984..466dddb4f79 100644 --- a/analysis/src/CompletionJsx.ml +++ b/analysis/src/CompletionJsx.ml @@ -251,7 +251,7 @@ let getJsxLabels ~componentPath ~findTypeOfValue ~package = match propsType |> getPropsType with | Some (path, typeArgs) -> getFields ~path ~typeArgs | None -> []) - | Tarrow (Nolabel, {desc = Tconstr (path, typeArgs, _)}, _, _) + | Tarrow (Nolabel, {desc = Tconstr (path, typeArgs, _)}, _, _, _) when Path.last path = "props" -> getFields ~path ~typeArgs | Tconstr (clPath, [{desc = Tconstr (path, typeArgs, _)}; _], _) @@ -259,7 +259,7 @@ let getJsxLabels ~componentPath ~findTypeOfValue ~package = && Path.last path = "props" -> (* JSX V4 external or interface *) getFields ~path ~typeArgs - | Tarrow (Nolabel, typ, _, _) -> ( + | Tarrow (Nolabel, typ, _, _, _) -> ( (* Component without the JSX PPX, like a make fn taking a hand-written type props. *) let rec digToConstr typ = diff --git a/analysis/src/CreateInterface.ml b/analysis/src/CreateInterface.ml index ebb936867fc..d95b87aaea8 100644 --- a/analysis/src/CreateInterface.ml +++ b/analysis/src/CreateInterface.ml @@ -124,7 +124,8 @@ let printSignature ~extractor ~signature = in match typ.desc with | Tconstr (Pident {name = "function$"}, [typ; _], _) -> getComponentType typ - | Tarrow (_, {desc = Tconstr (Path.Pident propsId, typeArgs, _)}, retType, _) + | Tarrow + (_, {desc = Tconstr (Path.Pident propsId, typeArgs, _)}, retType, _, _) when Ident.name propsId = "props" -> Some (typeArgs, retType) | Tconstr @@ -173,14 +174,17 @@ let printSignature ~extractor ~signature = if labelDecl.ld_optional then Asttypes.Optional lblName else Labelled lblName in - {retType with desc = Tarrow (lbl, propType, mkFunType rest, Cok)} + { + retType with + desc = Tarrow (lbl, propType, mkFunType rest, Cok, None); + } in let funType = if List.length labelDecls = 0 (* No props *) then let tUnit = Ctype.newconstr (Path.Pident (Ident.create "unit")) [] in - {retType with desc = Tarrow (Nolabel, tUnit, retType, Cok)} + {retType with desc = Tarrow (Nolabel, tUnit, retType, Cok, None)} else mkFunType labelDecls in sigItemToString diff --git a/analysis/src/Shared.ml b/analysis/src/Shared.ml index 18aac6043df..058ede61638 100644 --- a/analysis/src/Shared.ml +++ b/analysis/src/Shared.ml @@ -52,7 +52,7 @@ let findTypeConstructors (tel : Types.type_expr list) = | Tconstr (path, args, _) -> addPath path; args |> List.iter loop - | Tarrow (_, te1, te2, _) -> + | Tarrow (_, te1, te2, _, _) -> loop te1; loop te2 | Ttuple tel -> tel |> List.iter loop diff --git a/analysis/src/TypeUtils.ml b/analysis/src/TypeUtils.ml index 2f3dbe08dd8..3993cebee75 100644 --- a/analysis/src/TypeUtils.ml +++ b/analysis/src/TypeUtils.ml @@ -10,7 +10,7 @@ let debugLogTypeArgContext {env; typeArgs; typeParams} = let rec hasTvar (ty : Types.type_expr) : bool = match ty.desc with | Tvar _ -> true - | Tarrow (_, ty1, ty2, _) -> hasTvar ty1 || hasTvar ty2 + | Tarrow (_, ty1, ty2, _, _) -> hasTvar ty1 || hasTvar ty2 | Ttuple tyl -> List.exists hasTvar tyl | Tconstr (_, tyl, _) -> List.exists hasTvar tyl | Tobject (ty, _) -> hasTvar ty @@ -116,8 +116,8 @@ let instantiateType ~typeParams ~typeArgs (t : Types.type_expr) = | Tsubst t -> loop t | Tvariant rd -> {t with desc = Tvariant (rowDesc rd)} | Tnil -> t - | Tarrow (lbl, t1, t2, c) -> - {t with desc = Tarrow (lbl, loop t1, loop t2, c)} + | Tarrow (lbl, t1, t2, c, arity) -> + {t with desc = Tarrow (lbl, loop t1, loop t2, c, arity)} | Ttuple tl -> {t with desc = Ttuple (tl |> List.map loop)} | Tobject (t, r) -> {t with desc = Tobject (loop t, r)} | Tfield (n, k, t1, t2) -> {t with desc = Tfield (n, k, loop t1, loop t2)} @@ -169,8 +169,8 @@ let instantiateType2 ?(typeArgContext : typeArgContext option) | Tsubst t -> loop t | Tvariant rd -> {t with desc = Tvariant (rowDesc rd)} | Tnil -> t - | Tarrow (lbl, t1, t2, c) -> - {t with desc = Tarrow (lbl, loop t1, loop t2, c)} + | Tarrow (lbl, t1, t2, c, arity) -> + {t with desc = Tarrow (lbl, loop t1, loop t2, c, arity)} | Ttuple tl -> {t with desc = Ttuple (tl |> List.map loop)} | Tobject (t, r) -> {t with desc = Tobject (loop t, r)} | Tfield (n, k, t1, t2) -> {t with desc = Tfield (n, k, loop t1, loop t2)} @@ -242,7 +242,7 @@ let rec extractFunctionType ~env ~package typ = let rec loop ~env acc (t : Types.type_expr) = match t.desc with | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> loop ~env acc t1 - | Tarrow (label, tArg, tRet, _) -> loop ~env ((label, tArg) :: acc) tRet + | Tarrow (label, tArg, tRet, _, _) -> loop ~env ((label, tArg) :: acc) tRet | Tconstr (Pident {name = "function$"}, [t; _], _) -> extractFunctionType ~env ~package t | Tconstr (path, typeArgs, _) -> ( @@ -281,7 +281,7 @@ let rec extractFunctionType2 ?typeArgContext ~env ~package typ = let rec loop ?typeArgContext ~env acc (t : Types.type_expr) = match t.desc with | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> loop ?typeArgContext ~env acc t1 - | Tarrow (label, tArg, tRet, _) -> + | Tarrow (label, tArg, tRet, _, _) -> loop ?typeArgContext ~env ((label, tArg) :: acc) tRet | Tconstr (Pident {name = "function$"}, [t; _], _) -> extractFunctionType2 ?typeArgContext ~env ~package t @@ -912,12 +912,12 @@ let getArgs ~env (t : Types.type_expr) ~full = | Tpoly (t1, []) | Tconstr (Pident {name = "function$"}, [t1; _], _) -> getArgsLoop ~full ~env ~currentArgumentPosition t1 - | Tarrow (Labelled l, tArg, tRet, _) -> + | Tarrow (Labelled l, tArg, tRet, _, _) -> (SharedTypes.Completable.Labelled l, tArg) :: getArgsLoop ~full ~env ~currentArgumentPosition tRet - | Tarrow (Optional l, tArg, tRet, _) -> + | Tarrow (Optional l, tArg, tRet, _, _) -> (Optional l, tArg) :: getArgsLoop ~full ~env ~currentArgumentPosition tRet - | Tarrow (Nolabel, tArg, tRet, _) -> + | Tarrow (Nolabel, tArg, tRet, _, _) -> (Unlabelled {argumentPosition = currentArgumentPosition}, tArg) :: getArgsLoop ~full ~env ~currentArgumentPosition:(currentArgumentPosition + 1) diff --git a/compiler/frontend/ast_comb.ml b/compiler/frontend/ast_comb.ml index 0462a799688..3b1740145e3 100644 --- a/compiler/frontend/ast_comb.ml +++ b/compiler/frontend/ast_comb.ml @@ -40,7 +40,9 @@ let tuple_type_pair ?loc kind arity = match kind with | `Run -> (ty, [], ty) | `Make -> - (Ast_compatible.arrow ?loc (Ast_literal.type_unit ?loc ()) ty, [], ty) + ( Ast_compatible.arrow ?loc ~arity:None (Ast_literal.type_unit ?loc ()) ty, + [], + ty ) else let number = arity + 1 in let tys = @@ -50,7 +52,7 @@ let tuple_type_pair ?loc kind arity = match tys with | result :: rest -> ( Ext_list.reduce_from_left tys (fun r arg -> - Ast_compatible.arrow ?loc arg r), + Ast_compatible.arrow ?loc ~arity:None arg r), List.rev rest, result ) | [] -> assert false diff --git a/compiler/frontend/ast_compatible.ml b/compiler/frontend/ast_compatible.ml index 21e5c8d3ab3..b4d35952751 100644 --- a/compiler/frontend/ast_compatible.ml +++ b/compiler/frontend/ast_compatible.ml @@ -30,7 +30,8 @@ open Parsetree let default_loc = Location.none -let arrow ?loc ?attrs a b = Ast_helper.Typ.arrow ?loc ?attrs Nolabel a b +let arrow ?loc ?attrs ~arity a b = + Ast_helper.Typ.arrow ?loc ?attrs ~arity Nolabel a b let apply_simple ?(loc = default_loc) ?(attrs = []) (fn : expression) (args : expression list) : expression = @@ -94,16 +95,16 @@ let apply_labels ?(loc = default_loc) ?(attrs = []) fn Pexp_apply (fn, Ext_list.map args (fun (l, a) -> (Asttypes.Labelled l, a))); } -let label_arrow ?(loc = default_loc) ?(attrs = []) s a b : core_type = +let label_arrow ?(loc = default_loc) ?(attrs = []) ~arity s a b : core_type = { - ptyp_desc = Ptyp_arrow (Asttypes.Labelled s, a, b, None); + ptyp_desc = Ptyp_arrow (Asttypes.Labelled s, a, b, arity); ptyp_loc = loc; ptyp_attributes = attrs; } -let opt_arrow ?(loc = default_loc) ?(attrs = []) s a b : core_type = +let opt_arrow ?(loc = default_loc) ?(attrs = []) ~arity s a b : core_type = { - ptyp_desc = Ptyp_arrow (Asttypes.Optional s, a, b, None); + ptyp_desc = Ptyp_arrow (Asttypes.Optional s, a, b, arity); ptyp_loc = loc; ptyp_attributes = attrs; } diff --git a/compiler/frontend/ast_compatible.mli b/compiler/frontend/ast_compatible.mli index e2b68f601e0..185d14c93ac 100644 --- a/compiler/frontend/ast_compatible.mli +++ b/compiler/frontend/ast_compatible.mli @@ -90,11 +90,17 @@ val fun_ : expression *) val arrow : - ?loc:Location.t -> ?attrs:attrs -> core_type -> core_type -> core_type + ?loc:Location.t -> + ?attrs:attrs -> + arity:Asttypes.arity -> + core_type -> + core_type -> + core_type val label_arrow : ?loc:Location.t -> ?attrs:attrs -> + arity:Asttypes.arity -> string -> core_type -> core_type -> @@ -103,6 +109,7 @@ val label_arrow : val opt_arrow : ?loc:Location.t -> ?attrs:attrs -> + arity:Asttypes.arity -> string -> core_type -> core_type -> diff --git a/compiler/frontend/ast_core_type.ml b/compiler/frontend/ast_core_type.ml index d032a3aed6d..99cd941609a 100644 --- a/compiler/frontend/ast_core_type.ml +++ b/compiler/frontend/ast_core_type.ml @@ -95,7 +95,8 @@ let from_labels ~loc arity labels : t = in Ext_list.fold_right2 labels tyvars result_type (fun label (* {loc ; txt = label }*) tyvar acc -> - Ast_compatible.label_arrow ~loc:label.loc label.txt tyvar acc) + Ast_compatible.label_arrow ~loc:label.loc ~arity:(Some arity) label.txt + tyvar acc) let make_obj ~loc xs = Typ.object_ ~loc xs Closed diff --git a/compiler/frontend/ast_derive_abstract.ml b/compiler/frontend/ast_derive_abstract.ml index b4bcf122a21..895f721bf26 100644 --- a/compiler/frontend/ast_derive_abstract.ml +++ b/compiler/frontend/ast_derive_abstract.ml @@ -84,7 +84,8 @@ let handle_tdcl light (tdcl : Parsetree.type_declaration) : Ext_list.fold_right label_declarations ( [], (if has_optional_field then - Ast_compatible.arrow ~loc (Ast_literal.type_unit ()) core_type + Ast_compatible.arrow ~loc ~arity:None (Ast_literal.type_unit ()) + core_type else core_type), [] ) (fun ({ @@ -106,15 +107,17 @@ let handle_tdcl light (tdcl : Parsetree.type_declaration) : let maker, acc = if is_optional then let optional_type = Ast_core_type.lift_option_type pld_type in - ( Ast_compatible.opt_arrow ~loc:pld_loc label_name pld_type maker, + ( Ast_compatible.opt_arrow ~loc:pld_loc ~arity:None label_name + pld_type maker, Val.mk ~loc:pld_loc (if light then pld_name else {pld_name with txt = pld_name.txt ^ "Get"}) ~attrs:get_optional_attrs ~prim - (Ast_compatible.arrow ~loc core_type optional_type) + (Ast_compatible.arrow ~loc ~arity:None core_type optional_type) :: acc ) else - ( Ast_compatible.label_arrow ~loc:pld_loc label_name pld_type maker, + ( Ast_compatible.label_arrow ~loc:pld_loc ~arity:None label_name + pld_type maker, Val.mk ~loc:pld_loc (if light then pld_name else {pld_name with txt = pld_name.txt ^ "Get"}) @@ -124,15 +127,15 @@ let handle_tdcl light (tdcl : Parsetree.type_declaration) : External_ffi_types.ffi_bs_as_prims [External_arg_spec.dummy] Return_identity (Js_get {js_get_name = prim_as_name; js_get_scopes = []})) - (Ast_compatible.arrow ~loc core_type pld_type) + (Ast_compatible.arrow ~loc ~arity:None core_type pld_type) :: acc ) in let is_current_field_mutable = pld_mutable = Mutable in let acc = if is_current_field_mutable then let setter_type = - Ast_compatible.arrow core_type - (Ast_compatible.arrow pld_type (* setter *) + Ast_compatible.arrow ~arity:None core_type + (Ast_compatible.arrow ~arity:None pld_type (* setter *) (Ast_literal.type_unit ())) in Val.mk ~loc:pld_loc diff --git a/compiler/frontend/ast_derive_js_mapper.ml b/compiler/frontend/ast_derive_js_mapper.ml index cb2f7385b77..ec40b8e0a75 100644 --- a/compiler/frontend/ast_derive_js_mapper.ml +++ b/compiler/frontend/ast_derive_js_mapper.ml @@ -67,7 +67,7 @@ let erase_type_str = Str.primitive (Val.mk ~prim:["%identity"] {loc = noloc; txt = erase_type_lit} - (Ast_compatible.arrow any any)) + (Ast_compatible.arrow ~arity:None any any)) let unsafe_index = "_index" @@ -77,7 +77,8 @@ let unsafe_index_get = (Val.mk ~prim:[""] {loc = noloc; txt = unsafe_index} ~attrs:[Ast_attributes.get_index] - (Ast_compatible.arrow any (Ast_compatible.arrow any any))) + (Ast_compatible.arrow ~arity:None any + (Ast_compatible.arrow ~arity:None any any))) let unsafe_index_get_exp = Exp.ident {loc = noloc; txt = Lident unsafe_index} @@ -130,7 +131,7 @@ let app2 = Ast_compatible.app2 let ( ->~ ) a b = Ast_uncurried.uncurried_type ~loc:Location.none ~arity:1 - (Ast_compatible.arrow a b) + (Ast_compatible.arrow ~arity:(Some 1) a b) let raise_when_not_found_ident = Longident.Ldot (Lident Primitive_modules.util, "raiseWhenNotFound") @@ -295,7 +296,7 @@ let init () = let to_js_type result = Ast_comb.single_non_rec_val pat_to_js (Ast_uncurried.uncurried_type ~loc:Location.none ~arity:1 - (Ast_compatible.arrow 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 4506f52ca98..a35972018e7 100644 --- a/compiler/frontend/ast_derive_projector.ml +++ b/compiler/frontend/ast_derive_projector.ml @@ -140,7 +140,7 @@ 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 core_type pld_type + (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 ~loc:pld_name.loc)) @@ -169,7 +169,7 @@ let init () = 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 x acc) + Ast_compatible.arrow ~arity:None x acc) |> handle_uncurried_type_tranform ~arity ~loc)) | Ptype_open | Ptype_abstract -> Ast_derive_util.not_applicable tdcl.ptype_loc deriving_name; diff --git a/compiler/frontend/ast_exp_handle_external.ml b/compiler/frontend/ast_exp_handle_external.ml index 7fbeb6b30ef..df80c9a3d46 100644 --- a/compiler/frontend/ast_exp_handle_external.ml +++ b/compiler/frontend/ast_exp_handle_external.ml @@ -43,7 +43,7 @@ let handle_external loc (x : string) : Parsetree.expression = str_exp with pexp_desc = Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_expr"] - ~pval_type:(Typ.arrow Nolabel (Typ.any ()) (Typ.any ())) + ~pval_type:(Typ.arrow ~arity:None Nolabel (Typ.any ()) (Typ.any ())) [str_exp]; } in @@ -68,7 +68,8 @@ let handle_debugger loc (payload : Ast_payload.t) = match payload with | PStr [] -> Ast_external_mk.local_external_apply loc ~pval_prim:["%debugger"] - ~pval_type:(Typ.arrow Nolabel (Typ.any ()) (Ast_literal.type_unit ())) + ~pval_type: + (Typ.arrow ~arity:None Nolabel (Typ.any ()) (Ast_literal.type_unit ())) [Ast_literal.val_unit ~loc ()] | _ -> Location.raise_errorf ~loc "%%debugger extension doesn't accept arguments" @@ -92,7 +93,7 @@ let handle_raw ~kind loc payload = exp with pexp_desc = Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_expr"] - ~pval_type:(Typ.arrow Nolabel (Typ.any ()) (Typ.any ())) + ~pval_type:(Typ.arrow ~arity:None Nolabel (Typ.any ()) (Typ.any ())) [exp]; pexp_attributes = (match !is_function with @@ -119,9 +120,12 @@ let handle_ffi ~loc ~payload = let any = Ast_helper.Typ.any ~loc:e.pexp_loc () in let unit = Ast_literal.type_unit ~loc () in let rec arrow ~arity = - if arity = 0 then Ast_helper.Typ.arrow ~loc Nolabel unit any - else if arity = 1 then Ast_helper.Typ.arrow ~loc Nolabel any any - else Ast_helper.Typ.arrow ~loc Nolabel any (arrow ~arity:(arity - 1)) + if arity = 0 then Ast_helper.Typ.arrow ~arity:None ~loc Nolabel unit any + else if arity = 1 then + Ast_helper.Typ.arrow ~arity:None ~loc Nolabel any any + else + Ast_helper.Typ.arrow ~loc ~arity:None Nolabel any + (arrow ~arity:(arity - 1)) in match !is_function with | Some arity -> @@ -138,7 +142,7 @@ let handle_ffi ~loc ~payload = exp with pexp_desc = Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_expr"] - ~pval_type:(Typ.arrow Nolabel (Typ.any ()) (Typ.any ())) + ~pval_type:(Typ.arrow ~arity:None Nolabel (Typ.any ()) (Typ.any ())) [exp]; pexp_attributes = (match !is_function with @@ -154,7 +158,7 @@ let handle_raw_structure loc payload = exp with pexp_desc = Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_stmt"] - ~pval_type:(Typ.arrow Nolabel (Typ.any ()) (Typ.any ())) + ~pval_type:(Typ.arrow ~arity:None Nolabel (Typ.any ()) (Typ.any ())) [exp]; } | None -> diff --git a/compiler/frontend/ast_external_process.ml b/compiler/frontend/ast_external_process.ml index 8dc5f3ff26f..24824f9839c 100644 --- a/compiler/frontend/ast_external_process.ml +++ b/compiler/frontend/ast_external_process.ml @@ -935,12 +935,18 @@ let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type) match type_annotation.ptyp_desc with | Ptyp_constr (({txt = Lident "function$"; _} as lid), [t; arity_]) -> ( t, - fun ~arity x -> + fun ~arity (x : Parsetree.core_type) -> let t_arity = match arity with | Some arity -> Ast_uncurried.arity_type ~loc arity | None -> arity_ in + let x = + match x.ptyp_desc with + | Ptyp_arrow (l, t1, t2, _) -> + {x with ptyp_desc = Ptyp_arrow (l, t1, t2, arity)} + | _ -> x + in {x with Parsetree.ptyp_desc = Ptyp_constr (lid, [x; t_arity])} ) | _ -> (type_annotation, fun ~arity:_ x -> x) in diff --git a/compiler/frontend/ast_typ_uncurry.ml b/compiler/frontend/ast_typ_uncurry.ml index e60738f1724..c79daf08bac 100644 --- a/compiler/frontend/ast_typ_uncurry.ml +++ b/compiler/frontend/ast_typ_uncurry.ml @@ -33,7 +33,7 @@ let to_method_callback_type loc (mapper : Bs_ast_mapper.mapper) (typ : Parsetree.core_type) = let first_arg = mapper.typ mapper first_arg in let typ = mapper.typ mapper typ in - let meth_type = Typ.arrow ~loc label first_arg typ in + let meth_type = Typ.arrow ~loc ~arity:None label first_arg typ in let arity = Ast_core_type.get_uncurry_arity meth_type in match arity with | Some n -> @@ -57,8 +57,14 @@ let to_uncurry_type loc (mapper : Bs_ast_mapper.mapper) let first_arg = mapper.typ mapper first_arg in let typ = mapper.typ mapper typ in - let fn_type = Typ.arrow ~loc label first_arg typ in + let fn_type = Typ.arrow ~loc ~arity:None label first_arg typ in 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)} + | _ -> assert false + in match arity with | Some arity -> Ast_uncurried.uncurried_type ~loc ~arity fn_type | None -> assert false diff --git a/compiler/frontend/bs_ast_mapper.ml b/compiler/frontend/bs_ast_mapper.ml index f254386bc36..de29fd27917 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, _) -> - arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) + | Ptyp_arrow (lab, t1, t2, arity) -> + arrow ~loc ~attrs ~arity lab (sub.typ sub t1) (sub.typ sub t2) | 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/gentype/TranslateTypeExprFromTypes.ml b/compiler/gentype/TranslateTypeExprFromTypes.ml index d559a8215aa..02181693a25 100644 --- a/compiler/gentype/TranslateTypeExprFromTypes.ml +++ b/compiler/gentype/TranslateTypeExprFromTypes.ml @@ -270,7 +270,7 @@ let rec translate_arrow_type ~config ~type_vars_gen ~type_env ~rev_arg_deps | Tlink t -> translate_arrow_type ~config ~type_vars_gen ~type_env ~rev_arg_deps ~rev_args t - | Tarrow (Nolabel, type_expr1, type_expr2, _) -> + | Tarrow (Nolabel, type_expr1, type_expr2, _, _) -> let {dependencies; type_} = type_expr1 |> fun __x -> translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env __x @@ -280,7 +280,8 @@ let rec translate_arrow_type ~config ~type_vars_gen ~type_env ~rev_arg_deps |> translate_arrow_type ~config ~type_vars_gen ~type_env ~rev_arg_deps:next_rev_deps ~rev_args:((Nolabel, type_) :: rev_args) - | Tarrow (((Labelled lbl | Optional lbl) as label), type_expr1, type_expr2, _) + | Tarrow + (((Labelled lbl | Optional lbl) as label), type_expr1, type_expr2, _, _) -> ( match type_expr1 |> remove_option ~label with | None -> diff --git a/compiler/ml/ast_helper.ml b/compiler/ml/ast_helper.ml index d9024fa93ad..7160e65b59a 100644 --- a/compiler/ml/ast_helper.ml +++ b/compiler/ml/ast_helper.ml @@ -54,7 +54,7 @@ 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 = + let arrow ?loc ?attrs ~arity a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c, 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)) diff --git a/compiler/ml/ast_helper.mli b/compiler/ml/ast_helper.mli index 08c15fb846e..a8969d2d08d 100644 --- a/compiler/ml/ast_helper.mli +++ b/compiler/ml/ast_helper.mli @@ -57,7 +57,7 @@ module Typ : sig val arrow : ?loc:loc -> ?attrs:attrs -> - ?arity:int -> + arity:arity -> arg_label -> core_type -> core_type -> diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index b731e000e2b..83f1f6d761b 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, _) -> - arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) + | Ptyp_arrow (lab, t1, t2, arity) -> + arrow ~loc ~attrs ~arity lab (sub.typ sub t1) (sub.typ sub t2) | 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 e94a8f742f3..91cb6a809bf 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -99,7 +99,7 @@ module T = struct | Ptyp_any -> any ~loc ~attrs () | Ptyp_var s -> var ~loc ~attrs s | Ptyp_arrow (lab, t1, t2) -> - arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) + arrow ~loc ~attrs ~arity:None lab (sub.typ sub t1) (sub.typ sub t2) | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) | Ptyp_constr (lid, tl) -> ( let typ0 = diff --git a/compiler/ml/ast_uncurried.ml b/compiler/ml/ast_uncurried.ml index e1220f80c5d..ff678709077 100644 --- a/compiler/ml/ast_uncurried.ml +++ b/compiler/ml/ast_uncurried.ml @@ -83,20 +83,34 @@ let type_to_arity (t_arity : Types.type_expr) = | Tvariant {row_fields = [(label, _)]} -> decode_arity_string label | _ -> assert false -let make_uncurried_type ~env ~arity t = +let fun_type_to_arity (t_arity : Types.type_expr) = + match (Ctype.repr t_arity).desc with + | Tarrow (_, _, _, _, Some arity) -> arity + | Tarrow _ -> assert false + | _ -> assert false + +let make_uncurried_type ~env ~arity (t : Types.type_expr) = let typ_arity = arity_to_type arity in let lid : Longident.t = Lident "function$" in let path = Env.lookup_type lid env in + let t = + match t.desc with + | Tarrow (l, t1, t2, c, _) -> + let _ = assert false in + {t with desc = Tarrow (l, t1, t2, c, Some arity)} + | Tconstr _ -> assert false + | Tvar _ -> t + | _ -> assert false + in Ctype.newconstr path [t; typ_arity] let uncurried_type_get_arity ~env typ = match (Ctype.expand_head env typ).desc with - | Tconstr (Pident {name = "function$"}, [_t; t_arity], _) -> - type_to_arity t_arity + | Tconstr (Pident {name = "function$"}, [t; _arity], _) -> fun_type_to_arity t | _ -> assert false let uncurried_type_get_arity_opt ~env typ = match (Ctype.expand_head env typ).desc with - | Tconstr (Pident {name = "function$"}, [_t; t_arity], _) -> - Some (type_to_arity t_arity) + | Tconstr (Pident {name = "function$"}, [t; _arity], _) -> + Some (fun_type_to_arity t) | _ -> None diff --git a/compiler/ml/btype.ml b/compiler/ml/btype.ml index 461f1dbf05f..7afaf52f4bf 100644 --- a/compiler/ml/btype.ml +++ b/compiler/ml/btype.ml @@ -260,7 +260,7 @@ let rec iter_row f row = let iter_type_expr f ty = match ty.desc with | Tvar _ -> () - | Tarrow (_, ty1, ty2, _) -> + | Tarrow (_, ty1, ty2, _, _) -> f ty1; f ty2 | Ttuple l -> List.iter f l @@ -429,7 +429,8 @@ let rec norm_univar ty = let rec copy_type_desc ?(keep_names = false) f = function | Tvar _ as ty -> if keep_names then ty else Tvar None - | Tarrow (p, ty1, ty2, c) -> Tarrow (p, f ty1, f ty2, copy_commu c) + | Tarrow (p, ty1, ty2, c, arity) -> + Tarrow (p, f ty1, f ty2, copy_commu c, arity) | Ttuple l -> Ttuple (List.map f l) | Tconstr (p, l, _) -> Tconstr (p, List.map f l, ref Mnil) | Tobject (ty, {contents = Some (p, tl)}) -> diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index 14ae92491b5..e3cf10c61c6 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -699,7 +699,7 @@ let rec generalize_expansive env var_level visited ty = else generalize_expansive env var_level visited t) variance tyl | Tpackage (_, _, tyl) -> List.iter (generalize_structure var_level) tyl - | Tarrow (_, t1, t2, _) -> + | Tarrow (_, t1, t2, _, _) -> generalize_structure var_level t1; generalize_expansive env var_level visited t2 | _ -> iter_type_expr (generalize_expansive env var_level visited) ty) @@ -1894,7 +1894,7 @@ let rec mcomp type_pairs env t1 t2 = TypePairs.add type_pairs (t1', t2') (); match (t1'.desc, t2'.desc) with | Tvar _, Tvar _ -> assert false - | Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _) + | Tarrow (l1, t1, u1, _, _), Tarrow (l2, t2, u2, _, _) when Asttypes.same_arg_label l1 l2 || not (is_optional l1 || is_optional l2) -> mcomp type_pairs env t1 t2; @@ -2310,7 +2310,7 @@ and unify3 env t1 t1' t2 t2' = | Pattern -> add_type_equality t1' t2'); try (match (d1, d2) with - | Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2) + | Tarrow (l1, t1, u1, c1, _), Tarrow (l2, t2, u2, c2, _) when Asttypes.same_arg_label l1 l2 || (!umode = Pattern && not (is_optional l1 || is_optional l2)) -> ( @@ -2762,12 +2762,14 @@ let filter_arrow env t l = let t = expand_head_trace env t in match t.desc with | Tvar _ -> + let _ = assert false in + (* TODO: need the arity from the function definition *) let lv = t.level in let t1 = newvar2 lv and t2 = newvar2 lv in - let t' = newty2 lv (Tarrow (l, t1, t2, Cok)) in + let t' = newty2 lv (Tarrow (l, t1, t2, Cok, None)) in link_type t t'; (t1, t2) - | Tarrow (l', t1, t2, _) when Asttypes.same_arg_label l l' -> (t1, t2) + | Tarrow (l', t1, t2, _, _) when Asttypes.same_arg_label l l' -> (t1, t2) | _ -> raise (Unify []) (* Used by [filter_method]. *) @@ -2881,7 +2883,7 @@ let rec moregen inst_nongen type_pairs env t1 t2 = | Tvar _, _ when may_instantiate inst_nongen t1' -> moregen_occur env t1'.level t2; link_type t1' t2 - | Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _) + | Tarrow (l1, t1, u1, _, _), Tarrow (l2, t2, u2, _, _) when Asttypes.same_arg_label l1 l2 -> moregen inst_nongen type_pairs env t1 t2; moregen inst_nongen type_pairs env u1 u2 @@ -3151,7 +3153,7 @@ let rec eqtype rename type_pairs subst env t1 t2 = if List.exists (fun (_, t) -> t == t2') !subst then raise (Unify []); subst := (t1', t2') :: !subst) - | Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _) + | Tarrow (l1, t1, u1, _, _), Tarrow (l2, t2, u2, _, _) when Asttypes.same_arg_label l1 l2 -> eqtype rename type_pairs subst env t1 t2; eqtype rename type_pairs subst env u1 u2 @@ -3364,14 +3366,14 @@ let rec build_subtype env visited loops posi level t = (t', Equiv) with Not_found -> (t, Unchanged) else (t, Unchanged) - | Tarrow (l, t1, t2, _) -> + | Tarrow (l, t1, t2, _, a) -> if memq_warn t visited then (t, Unchanged) else let visited = t :: visited in let t1', c1 = build_subtype env visited loops (not posi) level t1 in let t2', c2 = build_subtype env visited loops posi level t2 in let c = max c1 c2 in - if c > Unchanged then (newty (Tarrow (l, t1', t2', Cok)), c) + if c > Unchanged then (newty (Tarrow (l, t1', t2', Cok, a)), c) else (t, Unchanged) | Ttuple tlist -> if memq_warn t visited then (t, Unchanged) @@ -3565,7 +3567,7 @@ let rec subtype_rec env trace t1 t2 cstrs = TypePairs.add subtypes (t1, t2) (); match (t1.desc, t2.desc) with | Tvar _, _ | _, Tvar _ -> (trace, t1, t2, !univar_pairs) :: cstrs - | Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _) + | Tarrow (l1, t1, u1, _, _), Tarrow (l2, t2, u2, _, _) when Asttypes.same_arg_label l1 l2 -> let cstrs = subtype_rec env ((t2, t1) :: trace) t2 t1 cstrs in subtype_rec env ((u1, u2) :: trace) u1 u2 cstrs @@ -3918,7 +3920,7 @@ let unalias ty = (* Return the arity (as for curried functions) of the given type. *) let rec arity ty = match (repr ty).desc with - | Tarrow (_, _t1, t2, _) -> 1 + arity t2 + | Tarrow (_, _t1, t2, _, _) -> 1 + arity t2 | _ -> 0 (* Check whether an abbreviation expands to itself. *) diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index 10716efaf21..6a796d54a1b 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -159,7 +159,7 @@ and raw_type_list tl = raw_list raw_type tl and raw_type_desc ppf = function | Tvar name -> fprintf ppf "Tvar %a" print_name name - | Tarrow (l, t1, t2, c) -> + | Tarrow (l, t1, t2, c, _) -> fprintf ppf "@[Tarrow(\"%s\",@,%a,@,%a,@,%s)@]" (string_of_label l) raw_type t1 raw_type t2 (safe_commu_repr [] c) | Ttuple tl -> fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl @@ -501,7 +501,7 @@ let rec mark_loops_rec visited ty = let visited = px :: visited in match ty.desc with | Tvar _ -> add_named_var ty - | Tarrow (_, ty1, ty2, _) -> + | Tarrow (_, ty1, ty2, _, _) -> mark_loops_rec visited ty1; mark_loops_rec visited ty2 | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl @@ -582,7 +582,7 @@ let rec tree_of_typexp sch ty = let non_gen = is_non_gen sch ty in let name_gen = if non_gen then new_weak_name ty else new_name in Otyp_var (non_gen, name_of_type name_gen ty) - | Tarrow (l, ty1, ty2, _) -> + | Tarrow (l, ty1, ty2, _, _) -> let pr_arrow l ty1 ty2 = let lab = string_of_label l in let t1 = diff --git a/compiler/ml/record_type_spread.ml b/compiler/ml/record_type_spread.ml index 73c283b60f9..82adebefeb8 100644 --- a/compiler/ml/record_type_spread.ml +++ b/compiler/ml/record_type_spread.ml @@ -22,8 +22,8 @@ let substitute_types ~type_map (t : Types.type_expr) = | Tsubst t -> {t with desc = Tsubst (loop t)} | Tvariant rd -> {t with desc = Tvariant (row_desc rd)} | Tnil -> t - | Tarrow (lbl, t1, t2, c) -> - {t with desc = Tarrow (lbl, loop t1, loop t2, c)} + | Tarrow (lbl, t1, t2, c, arity) -> + {t with desc = Tarrow (lbl, loop t1, loop t2, c, arity)} | Ttuple tl -> {t with desc = Ttuple (tl |> List.map loop)} | Tobject (t, r) -> {t with desc = Tobject (loop t, r)} | Tfield (n, k, t1, t2) -> {t with desc = Tfield (n, k, loop t1, loop t2)} diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index ce51b425e28..47753bc9974 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -702,7 +702,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = let expanded = Ctype.expand_head e.exp_env e.exp_type in let extracted = Ast_uncurried.type_extract_uncurried_fun expanded in match (Btype.repr extracted).desc with - | Tarrow (Nolabel, t, _, _) -> ( + | 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) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index abc46e0af74..e7f14719d28 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -730,10 +730,10 @@ let show_extra_help ppf _env trace = let rec collect_missing_arguments env type1 type2 = match type1 with (* why do we use Ctype.matches here? Please see https://github.com/rescript-lang/rescript-compiler/pull/2554 *) - | {Types.desc = Tarrow (label, argtype, typ, _)} + | {Types.desc = Tarrow (label, argtype, typ, _, _)} when Ctype.matches env typ type2 -> Some [(label, argtype)] - | {desc = Tarrow (label, argtype, typ, _)} -> ( + | {desc = Tarrow (label, argtype, typ, _, _)} -> ( match collect_missing_arguments env typ type2 with | Some res -> Some ((label, argtype) :: res) | None -> None) @@ -1895,9 +1895,9 @@ and is_nonexpansive_opt = function let rec approx_type env sty = match sty.ptyp_desc with - | Ptyp_arrow (p, _, sty, _) -> + | Ptyp_arrow (p, _, sty, a) -> let ty1 = if is_optional p then type_option (newvar ()) else newvar () in - newty (Tarrow (p, ty1, approx_type env sty, Cok)) + newty (Tarrow (p, ty1, approx_type env sty, Cok, a)) | Ptyp_tuple args -> newty (Ttuple (List.map (approx_type env) args)) | Ptyp_constr (lid, ctl) -> ( try @@ -1915,7 +1915,7 @@ let rec type_approx env sexp = | Pexp_let (_, _, e) -> type_approx env e | Pexp_fun (p, _, _, e, arity) -> ( let ty = if is_optional p then type_option (newvar ()) else newvar () in - let t = newty (Tarrow (p, ty, type_approx env e, Cok)) in + let t = newty (Tarrow (p, ty, type_approx env e, Cok, arity)) in match arity with | None -> t | Some arity -> Ast_uncurried.make_uncurried_type ~env ~arity t) @@ -1951,7 +1951,7 @@ let rec list_labels_aux env visited ls ty_fun = if List.memq ty visited then (List.rev ls, false) else match ty.desc with - | Tarrow (l, _, ty_res, _) -> + | Tarrow (l, _, ty_res, _, _) -> list_labels_aux env (ty :: visited) (l :: ls) ty_res | _ -> (List.rev ls, is_Tvar ty) @@ -2246,7 +2246,7 @@ let rec lower_args env seen ty_fun = if List.memq ty seen then () else match ty.desc with - | Tarrow (_l, ty_arg, ty_fun, _com) -> + | Tarrow (_l, ty_arg, ty_fun, _com, _) -> (try unify_var env (newvar ()) ty_arg with Unify _ -> assert false); lower_args env (ty :: seen) ty_fun | _ -> () @@ -3310,7 +3310,7 @@ 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 = instance env (newgenty (Tarrow (l, ty_arg, ty_res, Cok, assert false))) in let exp_type = match arity with | None -> exp_type @@ -3520,7 +3520,7 @@ and type_application ?type_clash_context uncurried env funct (sargs : sargs) : (* funct.exp_type may be generic *) let result_type omitted ty_fun = List.fold_left - (fun ty_fun (l, ty, lv) -> newty2 lv (Tarrow (l, ty, ty_fun, Cok))) + (fun ty_fun (l, ty, lv) -> newty2 lv (Tarrow (l, ty, ty_fun, Cok, None))) ty_fun omitted in let has_label l ty_fun = @@ -3582,8 +3582,8 @@ and type_application ?type_clash_context uncurried env funct (sargs : sargs) : (fully_applied, new_t) | _ -> (false, new_t) in - let rec type_unknown_args max_arity ~(args : lazy_args) omitted ty_fun - (syntax_args : sargs) : targs * _ = + let rec type_unknown_args max_arity ~(args : lazy_args) ~top_arity omitted + ty_fun (syntax_args : sargs) : targs * _ = match syntax_args with | [] -> let collect_args () = @@ -3596,20 +3596,21 @@ and type_application ?type_clash_context uncurried env funct (sargs : sargs) : in if List.length args < max_arity && uncurried then match (expand_head env ty_fun).desc with - | Tarrow (Optional l, t1, t2, _) -> + | Tarrow (Optional l, t1, t2, _, _) -> ignored := (Optional l, t1, ty_fun.level) :: !ignored; let arg = ( Optional l, Some (fun () -> option_none (instance env t1) Location.none) ) in - type_unknown_args max_arity ~args:(arg :: args) omitted t2 [] + type_unknown_args max_arity ~args:(arg :: args) ~top_arity:None + omitted t2 [] | _ -> collect_args () else collect_args () | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] when uncurried && omitted = [] && args <> [] && List.length args = List.length !ignored -> (* foo(. ) treated as empty application if all args are optional (hence ignored) *) - type_unknown_args max_arity ~args omitted ty_fun [] + type_unknown_args max_arity ~args ~top_arity:None omitted ty_fun [] | (l1, sarg1) :: sargl -> let ty1, ty2 = let ty_fun = expand_head env ty_fun in @@ -3619,9 +3620,11 @@ and type_application ?type_clash_context uncurried env funct (sargs : sargs) : let t1 = newvar () and t2 = newvar () in if ty_fun.level >= t1.level && not_identity funct.exp_desc then Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument; - unify env ty_fun (newty (Tarrow (l1, t1, t2, Clink (ref Cunknown)))); + unify env ty_fun + (newty (Tarrow (l1, t1, t2, Clink (ref Cunknown), top_arity))); (t1, t2) - | Tarrow (l, t1, t2, _) when Asttypes.same_arg_label l l1 && arity_ok -> + | Tarrow (l, t1, t2, _, _) when Asttypes.same_arg_label l l1 && arity_ok + -> (t1, t2) | td -> ( let ty_fun = @@ -3653,14 +3656,14 @@ and type_application ?type_clash_context uncurried env funct (sargs : sargs) : if optional then unify_exp env arg1 (type_option (newvar ())); arg1 in - type_unknown_args max_arity ~args:((l1, Some arg1) :: args) omitted ty2 - sargl + type_unknown_args max_arity ~args:((l1, Some arg1) :: args) + ~top_arity:None omitted ty2 sargl in let rec type_args ?type_clash_context max_arity args omitted ~ty_fun ty_fun0 - ~(sargs : sargs) = + ~(sargs : sargs) ~top_arity = match (expand_head env ty_fun, expand_head env ty_fun0) with - | ( {desc = Tarrow (l, ty, ty_fun, com); level = lv}, - {desc = Tarrow (_, ty0, ty_fun0, _)} ) + | ( {desc = Tarrow (l, ty, ty_fun, com, _); level = lv}, + {desc = Tarrow (_, ty0, ty_fun0, _, _)} ) when sargs <> [] && commu_repr com = Cok && List.length args < max_arity -> let name = label_name l and optional = is_optional l in @@ -3693,9 +3696,9 @@ and type_application ?type_clash_context uncurried env funct (sargs : sargs) : (extract_option_type env ty0))) ) in type_args ?type_clash_context max_arity ((l, arg) :: args) omitted ~ty_fun - ty_fun0 ~sargs + ty_fun0 ~sargs ~top_arity | _ -> - type_unknown_args max_arity ~args omitted ty_fun0 + type_unknown_args max_arity ~args ~top_arity omitted ty_fun0 sargs (* This is the hot path for non-labeled function*) in let () = @@ -3733,9 +3736,10 @@ and type_application ?type_clash_context uncurried env funct (sargs : sargs) : | _ -> if uncurried then force_uncurried_type funct; let ty, max_arity = extract_uncurried_type funct.exp_type in + let top_arity = if uncurried then Some max_arity else None in let targs, ret_t = type_args ?type_clash_context max_arity [] [] ~ty_fun:ty (instance env ty) - ~sargs + ~sargs ~top_arity in let fully_applied, ret_t = update_uncurried_arity funct.exp_type @@ -4367,10 +4371,10 @@ let report_error env ppf = function | Apply_non_function typ -> ( (* modified *) match (repr typ).desc with - | Tarrow (_, _inputType, return_type, _) -> + | Tarrow (_, _inputType, return_type, _, _) -> let rec count_number_of_args count {Types.desc} = match desc with - | Tarrow (_, _inputType, return_type, _) -> + | Tarrow (_, _inputType, return_type, _, _) -> count_number_of_args (count + 1) return_type | _ -> count in diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index 719a0cdea7d..3cffec68861 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -1010,7 +1010,7 @@ let compute_variance env visited vari ty = visited := TypeMap.add ty vari !visited; let compute_same = compute_variance_rec vari in match ty.desc with - | Tarrow (_, ty1, ty2, _) -> + | Tarrow (_, ty1, ty2, _, _) -> let open Variance in let v = conjugate vari in let v1 = @@ -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 (_, _, ct2, _), Tarrow (_, _, t2, _, _) -> 1 + arity_from_arrow_type env ct2 t2 | Ptyp_arrow _, _ | _, Tarrow _ -> assert false | _ -> 0 diff --git a/compiler/ml/typedtree.ml b/compiler/ml/typedtree.ml index 6d19e74be8d..e909a46b9f1 100644 --- a/compiler/ml/typedtree.ml +++ b/compiler/ml/typedtree.ml @@ -303,9 +303,8 @@ and with_constraint = | Twith_modsubst of Path.t * Longident.t loc and core_type = { - (* mutable because of [Typeclass.declare_method] *) - mutable ctyp_desc: core_type_desc; - mutable ctyp_type: type_expr; + ctyp_desc: core_type_desc; + ctyp_type: type_expr; ctyp_env: Env.t; (* BINANNOT ADDED *) ctyp_loc: Location.t; ctyp_attributes: attribute list; diff --git a/compiler/ml/typedtree.mli b/compiler/ml/typedtree.mli index fd2eba0024b..f75fdfa8f7f 100644 --- a/compiler/ml/typedtree.mli +++ b/compiler/ml/typedtree.mli @@ -408,10 +408,8 @@ and with_constraint = | Twith_modsubst of Path.t * Longident.t loc and core_type = { - mutable ctyp_desc: core_type_desc; - (** mutable because of [Typeclass.declare_method] *) - mutable ctyp_type: type_expr; - (** mutable because of [Typeclass.declare_method] *) + ctyp_desc: core_type_desc; + ctyp_type: type_expr; ctyp_env: Env.t; (* BINANNOT ADDED *) ctyp_loc: Location.t; ctyp_attributes: attributes; diff --git a/compiler/ml/typeopt.ml b/compiler/ml/typeopt.ml index d4b3a038a25..350269558aa 100644 --- a/compiler/ml/typeopt.ml +++ b/compiler/ml/typeopt.ml @@ -97,7 +97,7 @@ let rec type_cannot_contain_undefined (typ : Types.type_expr) (env : Env.t) = let is_function_type env ty = match scrape env ty with - | Tarrow (_, lhs, rhs, _) -> Some (lhs, rhs) + | Tarrow (_, lhs, rhs, _, _) -> Some (lhs, rhs) | _ -> None let is_base_type env ty base_ty_path = diff --git a/compiler/ml/types.ml b/compiler/ml/types.ml index 5b14935bc35..215f7e72b67 100644 --- a/compiler/ml/types.ml +++ b/compiler/ml/types.ml @@ -23,7 +23,7 @@ type type_expr = {mutable desc: type_desc; mutable level: int; id: int} and type_desc = | Tvar of string option - | Tarrow of arg_label * type_expr * type_expr * commutable + | Tarrow of arg_label * type_expr * type_expr * commutable * arity | Ttuple of type_expr list | Tconstr of Path.t * type_expr list * abbrev_memo ref | Tobject of type_expr * (Path.t * type_expr list) option ref diff --git a/compiler/ml/types.mli b/compiler/ml/types.mli index 9f3ac3397a7..ac09932a090 100644 --- a/compiler/ml/types.mli +++ b/compiler/ml/types.mli @@ -61,7 +61,7 @@ and type_desc = | Tvar of string option (** [Tvar (Some "a")] ==> ['a] or ['_a] [Tvar None] ==> [_] *) - | Tarrow of arg_label * type_expr * type_expr * commutable + | Tarrow of arg_label * type_expr * type_expr * commutable * arity (** [Tarrow (Nolabel, e1, e2, c)] ==> [e1 -> e2] [Tarrow (Labelled "l", e1, e2, c)] ==> [l:e1 -> e2] [Tarrow (Optional "l", e1, e2, c)] ==> [?l:e1 -> e2] diff --git a/compiler/ml/typetexp.ml b/compiler/ml/typetexp.ml index 51da4929d6c..bbd02d5498a 100644 --- a/compiler/ml/typetexp.ml +++ b/compiler/ml/typetexp.ml @@ -336,7 +336,7 @@ and transl_type_aux env policy styp = newty (Tconstr (Predef.path_option, [ty1], ref Mnil)) else ty1 in - let ty = newty (Tarrow (l, ty1, cty2.ctyp_type, Cok)) in + let ty = newty (Tarrow (l, ty1, cty2.ctyp_type, Cok, arity)) in ctyp (Ttyp_arrow (l, cty1, cty2, arity)) ty | Ptyp_tuple stl -> assert (List.length stl >= 2); diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index 676df152e51..e678dd90924 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -4072,7 +4072,7 @@ and parse_poly_type_expr p = 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 Asttypes.Nolabel typ return_type + Ast_helper.Typ.arrow ~loc ~arity:None Asttypes.Nolabel typ return_type in Ast_uncurried.uncurried_type ~loc ~arity:1 t_fun | _ -> Ast_helper.Typ.var ~loc:var.loc var.txt) @@ -4397,7 +4397,7 @@ and parse_es6_arrow_type ~attrs p = Parser.expect EqualGreater p; let return_type = parse_typ_expr ~alias:false p in let loc = mk_loc start_pos p.prev_end_pos in - Ast_helper.Typ.arrow ~loc ~attrs arg typ return_type + Ast_helper.Typ.arrow ~loc ~attrs ~arity:None arg typ return_type | DocComment _ -> assert false | _ -> let parameters = parse_type_parameters p in @@ -4425,7 +4425,9 @@ and parse_es6_arrow_type ~attrs p = else arity | _ -> arity in - let t_arg = Ast_helper.Typ.arrow ~loc ~attrs arg_lbl typ t in + let t_arg = + Ast_helper.Typ.arrow ~loc ~attrs ~arity:None arg_lbl typ t + in if param_num = 1 then (param_num - 1, Ast_uncurried.uncurried_type ~loc ~arity t_arg, 1) else (param_num - 1, t_arg, arity + 1)) @@ -4485,7 +4487,7 @@ and parse_arrow_type_rest ~es6_arrow ~start_pos typ 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 Asttypes.Nolabel typ return_type + Ast_helper.Typ.arrow ~loc ~arity:None Asttypes.Nolabel typ return_type in Ast_uncurried.uncurried_type ~loc ~arity:1 arrow_typ | _ -> typ @@ -5094,7 +5096,7 @@ 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 Asttypes.Nolabel typ return_type + Ast_helper.Typ.arrow ~loc ~arity:None Asttypes.Nolabel typ return_type in let arrow_type = Ast_uncurried.uncurried_type ~loc ~arity:1 arrow_type diff --git a/tests/syntax_tests/data/parsing/errors/other/expected/labelledParameters.res.txt b/tests/syntax_tests/data/parsing/errors/other/expected/labelledParameters.res.txt index 3417147d949..a65faff8463 100644 --- a/tests/syntax_tests/data/parsing/errors/other/expected/labelledParameters.res.txt +++ b/tests/syntax_tests/data/parsing/errors/other/expected/labelledParameters.res.txt @@ -34,4 +34,4 @@ let f [arity:3]x ?(y= 2) z = (x + y) + z let g [arity:3]~x:((x)[@res.namedArgLoc ]) ?y:(((y)[@res.namedArgLoc ])= 2) ~z:((z)[@res.namedArgLoc ]) = (x + y) + z -type nonrec f = (x:int -> y:int -> int, [ `Has_arity2 ]) function$ \ No newline at end of file +type nonrec f = (x:int -> y:int -> int (a:2), [ `Has_arity2 ]) function$ \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/errors/typeDef/expected/inlineRecord.res.txt b/tests/syntax_tests/data/parsing/errors/typeDef/expected/inlineRecord.res.txt index 24a0fc8dbb6..0e4870daf5a 100644 --- a/tests/syntax_tests/data/parsing/errors/typeDef/expected/inlineRecord.res.txt +++ b/tests/syntax_tests/data/parsing/errors/typeDef/expected/inlineRecord.res.txt @@ -46,6 +46,6 @@ type nonrec user = let make [arity:1](props : < - handleClick: (Click.t -> unit, [ `Has_arity1 ]) function$ ; - value: string > ) + handleClick: (Click.t -> unit (a:1), [ `Has_arity1 ]) + function$ ;value: string > ) = render props \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/expressions/expected/UncurriedByDefault.res.txt b/tests/syntax_tests/data/parsing/grammar/expressions/expected/UncurriedByDefault.res.txt index 35e991f4353..51381aa33c1 100644 --- a/tests/syntax_tests/data/parsing/grammar/expressions/expected/UncurriedByDefault.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/expressions/expected/UncurriedByDefault.res.txt @@ -6,62 +6,65 @@ let mixFun [arity:3]a b c [arity:3]d e f [arity:2]g h = 4 let bracesFun [arity:1]x [arity:1]y = x + y let cFun2 [arity:2]x y = 3 let uFun2 [arity:2]x y = 3 -type nonrec cTyp = (string -> int, [ `Has_arity1 ]) function$ -type nonrec uTyp = (string -> int, [ `Has_arity1 ]) function$ +type nonrec cTyp = (string -> int (a:1), [ `Has_arity1 ]) function$ +type nonrec uTyp = (string -> int (a:1), [ `Has_arity1 ]) function$ type nonrec mixTyp = (string -> string -> string -> (string -> string -> - string -> (string -> string -> int, [ `Has_arity2 ]) function$, - [ `Has_arity3 ]) function$, + string -> + (string -> string -> int (a:2), [ `Has_arity2 ]) function$ (a:3), + [ `Has_arity3 ]) function$ (a:3), [ `Has_arity3 ]) function$ type nonrec bTyp = - (string -> (string -> int, [ `Has_arity1 ]) function$, [ `Has_arity1 ]) - function$ -type nonrec cTyp2 = (string -> string -> int, [ `Has_arity2 ]) function$ -type nonrec uTyp2 = (string -> string -> int, [ `Has_arity2 ]) function$ -type nonrec cu = (unit -> int, [ `Has_arity1 ]) function$ -type nonrec cp = (unit -> int, [ `Has_arity1 ]) function$ + (string -> (string -> int (a:1), [ `Has_arity1 ]) function$ (a:1), + [ `Has_arity1 ]) function$ +type nonrec cTyp2 = + (string -> string -> int (a:2), [ `Has_arity2 ]) function$ +type nonrec uTyp2 = + (string -> string -> int (a:2), [ `Has_arity2 ]) function$ +type nonrec cu = (unit -> int (a:1), [ `Has_arity1 ]) function$ +type nonrec cp = (unit -> int (a:1), [ `Has_arity1 ]) function$ type nonrec cuu = - (unit -> (unit -> int, [ `Has_arity1 ]) function$, [ `Has_arity1 ]) - function$ + (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), + [ `Has_arity1 ]) function$ type nonrec cpu = - (unit -> (unit -> int, [ `Has_arity1 ]) function$, [ `Has_arity1 ]) - function$ + (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), + [ `Has_arity1 ]) function$ type nonrec cup = - (unit -> (unit -> int, [ `Has_arity1 ]) function$, [ `Has_arity1 ]) - function$ + (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), + [ `Has_arity1 ]) function$ type nonrec cpp = - (unit -> (unit -> int, [ `Has_arity1 ]) function$, [ `Has_arity1 ]) - function$ -type nonrec cu2 = (unit -> unit -> unit, [ `Has_arity2 ]) function$ -type nonrec cp2 = (unit -> unit -> unit, [ `Has_arity2 ]) function$ -type nonrec uu = (unit -> int, [ `Has_arity1 ]) function$ -type nonrec up = (unit -> int, [ `Has_arity1 ]) function$ + (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), + [ `Has_arity1 ]) function$ +type nonrec cu2 = (unit -> unit -> unit (a:2), [ `Has_arity2 ]) function$ +type nonrec cp2 = (unit -> unit -> unit (a:2), [ `Has_arity2 ]) function$ +type nonrec uu = (unit -> int (a:1), [ `Has_arity1 ]) function$ +type nonrec up = (unit -> int (a:1), [ `Has_arity1 ]) function$ type nonrec uuu = - (unit -> (unit -> int, [ `Has_arity1 ]) function$, [ `Has_arity1 ]) - function$ + (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), + [ `Has_arity1 ]) function$ type nonrec upu = - (unit -> (unit -> int, [ `Has_arity1 ]) function$, [ `Has_arity1 ]) - function$ + (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), + [ `Has_arity1 ]) function$ type nonrec uup = - (unit -> (unit -> int, [ `Has_arity1 ]) function$, [ `Has_arity1 ]) - function$ + (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), + [ `Has_arity1 ]) function$ type nonrec upp = - (unit -> (unit -> int, [ `Has_arity1 ]) function$, [ `Has_arity1 ]) - function$ -type nonrec uu2 = (unit -> unit -> unit, [ `Has_arity2 ]) function$ -type nonrec up2 = (unit -> unit -> unit, [ `Has_arity2 ]) function$ + (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), + [ `Has_arity1 ]) function$ +type nonrec uu2 = (unit -> unit -> unit (a:2), [ `Has_arity2 ]) function$ +type nonrec up2 = (unit -> unit -> unit (a:2), [ `Has_arity2 ]) function$ type nonrec cnested = - ((string -> unit, [ `Has_arity1 ]) function$ -> unit, [ `Has_arity1 ]) - function$ + ((string -> unit (a:1), [ `Has_arity1 ]) function$ -> unit (a:1), + [ `Has_arity1 ]) function$ type nonrec unested = - ((string -> unit, [ `Has_arity1 ]) function$ -> unit, [ `Has_arity1 ]) - function$ -let (uannpoly : ('a -> string, [ `Has_arity1 ]) function$) = xx -let (uannint : (int -> string, [ `Has_arity1 ]) function$) = xx + ((string -> unit (a:1), [ `Has_arity1 ]) function$ -> unit (a:1), + [ `Has_arity1 ]) function$ +let (uannpoly : ('a -> string (a:1), [ `Has_arity1 ]) function$) = xx +let (uannint : (int -> string (a:1), [ `Has_arity1 ]) function$) = xx let _ = ((fun [arity:1]x -> 34)[@att ]) let _ = ((fun [arity:1]x -> 34)[@res.async ][@att ]) let _ = preserveAttr ((fun [arity:1]x -> 34)[@att ]) @@ -73,16 +76,16 @@ let t3 (type a) (type b) [arity:2](l : a list) (x : a) = x :: l let t4 (type a) (type b) [arity:2](l : a list) (x : a) = x :: l let t5 (type a) (type b) [arity:2](l : a list) (x : a) = x :: l let t6 (type a) (type b) [arity:2](l : a list) (x : a) = x :: l -type nonrec arrowPath1 = (int -> string, [ `Has_arity1 ]) function$ -type nonrec arrowPath2 = (I.t -> string, [ `Has_arity1 ]) function$ -type nonrec arrowPath3 = (int -> string, [ `Has_arity1 ]) function$ -type nonrec arrowPath4 = (I.t -> string, [ `Has_arity1 ]) function$ +type nonrec arrowPath1 = (int -> string (a:1), [ `Has_arity1 ]) function$ +type nonrec arrowPath2 = (I.t -> string (a:1), [ `Has_arity1 ]) function$ +type nonrec arrowPath3 = (int -> string (a:1), [ `Has_arity1 ]) function$ +type nonrec arrowPath4 = (I.t -> string (a:1), [ `Has_arity1 ]) function$ type nonrec callback1 = - (ReactEvent.Mouse.t -> unit, [ `Has_arity1 ]) function$ as 'callback + (ReactEvent.Mouse.t -> unit (a:1), [ `Has_arity1 ]) function$ as 'callback type nonrec callback2 = - (ReactEvent.Mouse.t -> unit as 'u, [ `Has_arity1 ]) function$ + (ReactEvent.Mouse.t -> unit as 'u (a:1), [ `Has_arity1 ]) function$ type nonrec callback3 = - (ReactEvent.Mouse.t -> unit, [ `Has_arity1 ]) function$ as 'callback + (ReactEvent.Mouse.t -> unit (a:1), [ `Has_arity1 ]) function$ as 'callback let cApp = foo 3 let uApp = foo 3 let cFun [arity:1]x = 3 @@ -92,64 +95,67 @@ let bracesFun [arity:1]x [arity:1]y = x + y let cFun2 [arity:2]x y = 3 let uFun2 [arity:2]x y = 3 let cFun2Dots [arity:2]x y = 3 -type nonrec cTyp = (string -> int, [ `Has_arity1 ]) function$ -type nonrec uTyp = (string -> int, [ `Has_arity1 ]) function$ +type nonrec cTyp = (string -> int (a:1), [ `Has_arity1 ]) function$ +type nonrec uTyp = (string -> int (a:1), [ `Has_arity1 ]) function$ type nonrec mixTyp = (string -> (string -> string -> (string -> string -> - string -> string -> (string -> int, [ `Has_arity1 ]) function$, - [ `Has_arity4 ]) function$, - [ `Has_arity2 ]) function$, + string -> + string -> (string -> int (a:1), [ `Has_arity1 ]) function$ (a:4), + [ `Has_arity4 ]) function$ (a:2), + [ `Has_arity2 ]) function$ (a:1), [ `Has_arity1 ]) function$ type nonrec bTyp = - (string -> (string -> int, [ `Has_arity1 ]) function$, [ `Has_arity1 ]) - function$ -type nonrec cTyp2 = (string -> string -> int, [ `Has_arity2 ]) function$ -type nonrec uTyp2 = (string -> string -> int, [ `Has_arity2 ]) function$ -type nonrec cu = (unit -> int, [ `Has_arity1 ]) function$ -type nonrec cp = (unit -> int, [ `Has_arity1 ]) function$ + (string -> (string -> int (a:1), [ `Has_arity1 ]) function$ (a:1), + [ `Has_arity1 ]) function$ +type nonrec cTyp2 = + (string -> string -> int (a:2), [ `Has_arity2 ]) function$ +type nonrec uTyp2 = + (string -> string -> int (a:2), [ `Has_arity2 ]) function$ +type nonrec cu = (unit -> int (a:1), [ `Has_arity1 ]) function$ +type nonrec cp = (unit -> int (a:1), [ `Has_arity1 ]) function$ type nonrec cuu = - (unit -> (unit -> int, [ `Has_arity1 ]) function$, [ `Has_arity1 ]) - function$ + (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), + [ `Has_arity1 ]) function$ type nonrec cpu = - (unit -> (unit -> int, [ `Has_arity1 ]) function$, [ `Has_arity1 ]) - function$ + (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), + [ `Has_arity1 ]) function$ type nonrec cup = - (unit -> (unit -> int, [ `Has_arity1 ]) function$, [ `Has_arity1 ]) - function$ + (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), + [ `Has_arity1 ]) function$ type nonrec cpp = - (unit -> (unit -> int, [ `Has_arity1 ]) function$, [ `Has_arity1 ]) - function$ -type nonrec cu2 = (unit -> unit -> unit, [ `Has_arity2 ]) function$ -type nonrec cp2 = (unit -> unit -> unit, [ `Has_arity2 ]) function$ -type nonrec uu = (unit -> int, [ `Has_arity1 ]) function$ -type nonrec up = (unit -> int, [ `Has_arity1 ]) function$ + (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), + [ `Has_arity1 ]) function$ +type nonrec cu2 = (unit -> unit -> unit (a:2), [ `Has_arity2 ]) function$ +type nonrec cp2 = (unit -> unit -> unit (a:2), [ `Has_arity2 ]) function$ +type nonrec uu = (unit -> int (a:1), [ `Has_arity1 ]) function$ +type nonrec up = (unit -> int (a:1), [ `Has_arity1 ]) function$ type nonrec uuu = - (unit -> (unit -> int, [ `Has_arity1 ]) function$, [ `Has_arity1 ]) - function$ + (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), + [ `Has_arity1 ]) function$ type nonrec upu = - (unit -> (unit -> int, [ `Has_arity1 ]) function$, [ `Has_arity1 ]) - function$ + (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), + [ `Has_arity1 ]) function$ type nonrec uup = - (unit -> (unit -> int, [ `Has_arity1 ]) function$, [ `Has_arity1 ]) - function$ + (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), + [ `Has_arity1 ]) function$ type nonrec upp = - (unit -> (unit -> int, [ `Has_arity1 ]) function$, [ `Has_arity1 ]) - function$ -type nonrec uu2 = (unit -> unit -> unit, [ `Has_arity2 ]) function$ -type nonrec up2 = (unit -> unit -> unit, [ `Has_arity2 ]) function$ + (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), + [ `Has_arity1 ]) function$ +type nonrec uu2 = (unit -> unit -> unit (a:2), [ `Has_arity2 ]) function$ +type nonrec up2 = (unit -> unit -> unit (a:2), [ `Has_arity2 ]) function$ type nonrec cnested = - ((string -> unit, [ `Has_arity1 ]) function$ -> unit, [ `Has_arity1 ]) - function$ + ((string -> unit (a:1), [ `Has_arity1 ]) function$ -> unit (a:1), + [ `Has_arity1 ]) function$ type nonrec unested = - ((string -> unit, [ `Has_arity1 ]) function$ -> unit, [ `Has_arity1 ]) - function$ + ((string -> unit (a:1), [ `Has_arity1 ]) function$ -> unit (a:1), + [ `Has_arity1 ]) function$ let pipe1 = 3 |.u f -let (uannpoly : ('a -> string, [ `Has_arity1 ]) function$) = xx -let (uannint : (int -> string, [ `Has_arity1 ]) function$) = xx +let (uannpoly : ('a -> string (a:1), [ `Has_arity1 ]) function$) = xx +let (uannint : (int -> string (a:1), [ `Has_arity1 ]) function$) = xx let _ = ((fun [arity:1]x -> 34)[@att ]) let _ = ((fun [arity:1]x -> 34)[@res.async ][@att ]) let _ = preserveAttr ((fun [arity:1]x -> 34)[@att ]) @@ -158,13 +164,13 @@ let t0 (type a) (type b) [arity:2](l : a list) (x : a) = x :: l let t1 (type a) (type b) [arity:2](l : a list) (x : a) = x :: l let t2 (type a) (type b) [arity:2](l : a list) (x : a) = x :: l let t3 (type a) (type b) [arity:2](l : a list) (x : a) = x :: l -type nonrec arrowPath1 = (int -> string, [ `Has_arity1 ]) function$ -type nonrec arrowPath2 = (I.t -> string, [ `Has_arity1 ]) function$ -type nonrec arrowPath3 = (int -> string, [ `Has_arity1 ]) function$ -type nonrec arrowPath4 = (I.t -> string, [ `Has_arity1 ]) function$ +type nonrec arrowPath1 = (int -> string (a:1), [ `Has_arity1 ]) function$ +type nonrec arrowPath2 = (I.t -> string (a:1), [ `Has_arity1 ]) function$ +type nonrec arrowPath3 = (int -> string (a:1), [ `Has_arity1 ]) function$ +type nonrec arrowPath4 = (I.t -> string (a:1), [ `Has_arity1 ]) function$ type nonrec callback1 = - (ReactEvent.Mouse.t -> unit, [ `Has_arity1 ]) function$ as 'callback + (ReactEvent.Mouse.t -> unit (a:1), [ `Has_arity1 ]) function$ as 'callback type nonrec callback2 = - (ReactEvent.Mouse.t -> unit as 'u, [ `Has_arity1 ]) function$ + (ReactEvent.Mouse.t -> unit as 'u (a:1), [ `Has_arity1 ]) function$ type nonrec callback3 = - (ReactEvent.Mouse.t -> unit, [ `Has_arity1 ]) function$ as 'callback \ No newline at end of file + (ReactEvent.Mouse.t -> unit (a:1), [ `Has_arity1 ]) function$ as 'callback \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/expressions/expected/arrow.res.txt b/tests/syntax_tests/data/parsing/grammar/expressions/expected/arrow.res.txt index ee09e1ad096..ac823014385 100644 --- a/tests/syntax_tests/data/parsing/grammar/expressions/expected/arrow.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/expressions/expected/arrow.res.txt @@ -83,5 +83,5 @@ let un = (() : u) type nonrec ('a, 'b) d = ('a * 'b) let c [arity:1]() = ((1, 2) : ('a, 'b) d) let fn [arity:1]f = f -type nonrec f = (int -> unit, [ `Has_arity1 ]) function$ +type nonrec f = (int -> unit (a:1), [ `Has_arity1 ]) function$ let a = fn (fun [arity:1]_ -> () : f) \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/expressions/expected/block.res.txt b/tests/syntax_tests/data/parsing/grammar/expressions/expected/block.res.txt index 83cbea1dee3..723f3f5b212 100644 --- a/tests/syntax_tests/data/parsing/grammar/expressions/expected/block.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/expressions/expected/block.res.txt @@ -53,7 +53,7 @@ let reifyStyle (type a) [arity:1](x : 'a) = let instanceOf = ([%raw (({js|function(x,y) {return +(x instanceof y)}|js}) - [@res.template ])] : ('a -> constructor -> bool, + [@res.template ])] : ('a -> constructor -> bool (a:2), [ `Has_arity2 ]) function$) end in ((if (Js.typeof x) = {js|string|js} diff --git a/tests/syntax_tests/data/parsing/grammar/expressions/expected/locallyAbstractTypes.res.txt b/tests/syntax_tests/data/parsing/grammar/expressions/expected/locallyAbstractTypes.res.txt index 162b62c4faf..988d3b4fc77 100644 --- a/tests/syntax_tests/data/parsing/grammar/expressions/expected/locallyAbstractTypes.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/expressions/expected/locallyAbstractTypes.res.txt @@ -13,7 +13,8 @@ let f = ((fun (type t) -> ((fun (type s) -> [@attr ]))[@attr ]) let cancel_and_collect_callbacks : 'a 'u 'c . - (packed_callbacks list -> ('a, 'u, 'c) promise -> packed_callbacks list, + (packed_callbacks list -> + ('a, 'u, 'c) promise -> packed_callbacks list (a:2), [ `Has_arity2 ]) function$ = fun (type x) -> fun [arity:2]callbacks_accumulator -> fun (p : (_, _, c) promise) -> () \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/modexpr/expected/functor.res.txt b/tests/syntax_tests/data/parsing/grammar/modexpr/expected/functor.res.txt index 292fe7c79f7..6e1d4b1e661 100644 --- a/tests/syntax_tests/data/parsing/grammar/modexpr/expected/functor.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/modexpr/expected/functor.res.txt @@ -16,13 +16,13 @@ include functor () -> Map include ((functor () -> Map)[@functorAttr ]) module Make(Cmp:sig type nonrec t - val eq : (t -> t -> bool, [ `Has_arity2 ]) function$ + val eq : (t -> t -> bool (a:2), [ `Has_arity2 ]) function$ end) : sig type nonrec key = Cmp.t type nonrec coll val empty : coll - val add : (coll -> key -> coll, [ `Has_arity2 ]) function$ + val add : (coll -> key -> coll (a:2), [ `Has_arity2 ]) function$ end = struct open Cmp diff --git a/tests/syntax_tests/data/parsing/grammar/modtype/expected/parenthesized.res.txt b/tests/syntax_tests/data/parsing/grammar/modtype/expected/parenthesized.res.txt index 462e4dd07a6..a69378931a9 100644 --- a/tests/syntax_tests/data/parsing/grammar/modtype/expected/parenthesized.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/modtype/expected/parenthesized.res.txt @@ -4,11 +4,13 @@ module type Bt = ((Btree)[@attrIdent ][@attrParens ]) module type MyHash = sig include module type of struct include Hashtbl end - val replace : (('a, 'b) t -> 'a -> 'b -> unit, [ `Has_arity3 ]) function$ + val replace : + (('a, 'b) t -> 'a -> 'b -> unit (a:3), [ `Has_arity3 ]) function$ end module type MyHash = sig include ((module type of struct include Hashtbl end)[@onModTypeOf ][@onParens ]) - val replace : (('a, 'b) t -> 'a -> 'b -> unit, [ `Has_arity3 ]) function$ + val replace : + (('a, 'b) t -> 'a -> 'b -> unit (a:3), [ `Has_arity3 ]) function$ end \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/modtype/expected/typeof.res.txt b/tests/syntax_tests/data/parsing/grammar/modtype/expected/typeof.res.txt index 27b03d24e22..5b068bb97a5 100644 --- a/tests/syntax_tests/data/parsing/grammar/modtype/expected/typeof.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/modtype/expected/typeof.res.txt @@ -1,10 +1,12 @@ module type MyHash = sig include module type of struct include Hashtbl end - val replace : (('a, 'b) t -> 'a -> 'b -> unit, [ `Has_arity3 ]) function$ + val replace : + (('a, 'b) t -> 'a -> 'b -> unit (a:3), [ `Has_arity3 ]) function$ end module type MyHash = sig include ((module type of struct include Hashtbl end)[@onModuleTypeOf ]) - val replace : (('a, 'b) t -> 'a -> 'b -> unit, [ `Has_arity3 ]) function$ + val replace : + (('a, 'b) t -> 'a -> 'b -> unit (a:3), [ `Has_arity3 ]) function$ end \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/modtype/expected/with.res.txt b/tests/syntax_tests/data/parsing/grammar/modtype/expected/with.res.txt index ad7b6d9b503..0caa9c3bbfc 100644 --- a/tests/syntax_tests/data/parsing/grammar/modtype/expected/with.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/modtype/expected/with.res.txt @@ -31,10 +31,13 @@ module type A = module type Printable = sig type nonrec t - val print : (Format.formatter -> t -> unit, [ `Has_arity2 ]) function$ + val print : + (Format.formatter -> t -> unit (a:2), [ `Has_arity2 ]) function$ end module type Comparable = - sig type nonrec t val compare : (t -> t -> int, [ `Has_arity2 ]) function$ + sig + type nonrec t + val compare : (t -> t -> int (a:2), [ `Has_arity2 ]) function$ end module type PrintableComparable = sig include Printable include (Comparable with type t := t) end \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/signature/expected/external.res.txt b/tests/syntax_tests/data/parsing/grammar/signature/expected/external.res.txt index 5a5e012aa2a..c7dd1f41a68 100644 --- a/tests/syntax_tests/data/parsing/grammar/signature/expected/external.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/signature/expected/external.res.txt @@ -2,11 +2,13 @@ module type Signature = sig type nonrec t external linkProgram : - (t -> program:((webGlProgram)[@res.namedArgLoc ]) -> unit, + (t -> program:((webGlProgram)[@res.namedArgLoc ]) -> unit (a:2), [ `Has_arity2 ]) function$ = "linkProgram"[@@send ] external add_nat : - (nat -> int -> int -> int, [ `Has_arity3 ]) function$ = + (nat -> int -> int -> int (a:3), [ `Has_arity3 ]) function$ = "add_nat_bytecode" - external svg : (unit -> React.element, [ `Has_arity1 ]) function$ = "svg" - external svg : (unit -> React.element, [ `Has_arity1 ]) function$ = "svg" + external svg : + (unit -> React.element (a:1), [ `Has_arity1 ]) function$ = "svg" + external svg : + (unit -> React.element (a:1), [ `Has_arity1 ]) function$ = "svg" end \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/signature/expected/recModule.res.txt b/tests/syntax_tests/data/parsing/grammar/signature/expected/recModule.res.txt index 831702d0ba4..63a729d24f4 100644 --- a/tests/syntax_tests/data/parsing/grammar/signature/expected/recModule.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/signature/expected/recModule.res.txt @@ -5,7 +5,7 @@ module type Signature = type nonrec t = | Leaf of string | Node of ASet.t - val compare : (t -> t -> int, [ `Has_arity2 ]) function$ + val compare : (t -> t -> int (a:2), [ `Has_arity2 ]) function$ end and ASet: (Set.S with type elt = A.t) and BTree: (Btree.S with type elt = A.t) @@ -14,7 +14,7 @@ module type Signature = type nonrec t = | Leaf of string | Node of ASet.t - val compare : (t -> t -> int, [ `Has_arity2 ]) function$ + val compare : (t -> t -> int (a:2), [ `Has_arity2 ]) function$ end[@@onFirstAttr ] and ASet: (Set.S with type elt = A.t)[@@onSecondAttr ] module rec A: Btree[@@parsableOnNext ] diff --git a/tests/syntax_tests/data/parsing/grammar/structure/expected/externalDefinition.res.txt b/tests/syntax_tests/data/parsing/grammar/structure/expected/externalDefinition.res.txt index 1ed836fd341..aa35574435c 100644 --- a/tests/syntax_tests/data/parsing/grammar/structure/expected/externalDefinition.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/structure/expected/externalDefinition.res.txt @@ -1,13 +1,16 @@ -external clear : (t -> int -> unit, [ `Has_arity2 ]) function$ = "clear" +external clear : + (t -> int -> unit (a:2), [ `Has_arity2 ]) function$ = "clear" external add_nat : - (nat -> int, [ `Has_arity1 ]) function$ = "add_nat_bytecode" + (nat -> int (a:1), [ `Has_arity1 ]) function$ = "add_nat_bytecode" external attachShader : (t -> program:((webGlProgram)[@res.namedArgLoc ]) -> - shader:((webGlShader)[@res.namedArgLoc ]) -> unit, + shader:((webGlShader)[@res.namedArgLoc ]) -> unit (a:3), [ `Has_arity3 ]) function$ = "attachShader"[@@send ] -external svg : (unit -> React.element, [ `Has_arity1 ]) function$ = "svg" -external svg : (unit -> React.element, [ `Has_arity1 ]) function$ = "svg" +external svg : + (unit -> React.element (a:1), [ `Has_arity1 ]) function$ = "svg" +external svg : + (unit -> React.element (a:1), [ `Has_arity1 ]) function$ = "svg" external createDate : - (unit -> unit -> date, [ `Has_arity2 ]) function$ = "Date"[@@new ] + (unit -> unit -> date (a:2), [ `Has_arity2 ]) function$ = "Date"[@@new ] let foobar = (createDate ()) () \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/typedefinition/expected/constructorDeclaration.res.txt b/tests/syntax_tests/data/parsing/grammar/typedefinition/expected/constructorDeclaration.res.txt index 05bf6b484f1..18d6b493225 100644 --- a/tests/syntax_tests/data/parsing/grammar/typedefinition/expected/constructorDeclaration.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/typedefinition/expected/constructorDeclaration.res.txt @@ -83,12 +83,14 @@ type nonrec (_, 'value) node = mutable cachedValue: 'value ; parent: (_, 'value) node ; root: (root, 'value) node ; - updateF: ('value -> 'value, [ `Has_arity1 ]) function$ ; + updateF: ('value -> 'value (a:1), [ `Has_arity1 ]) function$ ; mutable updatedTime: float } -> (derived, 'value) node type nonrec delta = - | Compute of (< blocked_ids: unit > -> unit, [ `Has_arity1 ]) function$ + | Compute of (< blocked_ids: unit > -> unit (a:1), [ `Has_arity1 ]) + function$ type nonrec queryDelta = - | Compute of (< blocked_ids: unit > -> unit, [ `Has_arity1 ]) function$ - - | Compute of (< blocked_ids: unit > -> unit, [ `Has_arity1 ]) function$ - * (< allowed_ids: unit > -> unit, [ `Has_arity1 ]) function$ \ No newline at end of file + | Compute of (< blocked_ids: unit > -> unit (a:1), [ `Has_arity1 ]) + function$ + | Compute of (< blocked_ids: unit > -> unit (a:1), [ `Has_arity1 ]) + function$ * (< allowed_ids: unit > -> unit (a:1), [ `Has_arity1 ]) + function$ \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/typedefinition/expected/privateTypeEquation.res.txt b/tests/syntax_tests/data/parsing/grammar/typedefinition/expected/privateTypeEquation.res.txt index c4c2a63df9e..83fe17db85b 100644 --- a/tests/syntax_tests/data/parsing/grammar/typedefinition/expected/privateTypeEquation.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/typedefinition/expected/privateTypeEquation.res.txt @@ -2,13 +2,14 @@ type nonrec t = private 'a type nonrec t = private string type nonrec t = private _ type nonrec t = private int -type nonrec t = private (int -> int, [ `Has_arity1 ]) function$ -type nonrec t = private (int -> int, [ `Has_arity1 ]) function$ +type nonrec t = private (int -> int (a:1), [ `Has_arity1 ]) function$ +type nonrec t = private (int -> int (a:1), [ `Has_arity1 ]) function$ type nonrec t = private - (int -> (int -> int, [ `Has_arity1 ]) function$, [ `Has_arity1 ]) function$ + (int -> (int -> int (a:1), [ `Has_arity1 ]) function$ (a:1), + [ `Has_arity1 ]) function$ type nonrec t = private - (int -> x:((string)[@res.namedArgLoc ]) -> float -> unit, [ `Has_arity3 ]) - function$ + (int -> x:((string)[@res.namedArgLoc ]) -> float -> unit (a:3), + [ `Has_arity3 ]) function$ type nonrec t = private string as 'x type nonrec t = private [%ext ] type nonrec t = private [%ext {js|console.log|js}] diff --git a/tests/syntax_tests/data/parsing/grammar/typedefinition/expected/typeInformation.res.txt b/tests/syntax_tests/data/parsing/grammar/typedefinition/expected/typeInformation.res.txt index 68fe6265318..2b74ca5c83c 100644 --- a/tests/syntax_tests/data/parsing/grammar/typedefinition/expected/typeInformation.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/typedefinition/expected/typeInformation.res.txt @@ -71,8 +71,8 @@ type nonrec t = { x: int ; y: int } type nonrec callback = - (ReactEvent.Mouse.t -> unit, [ `Has_arity1 ]) function$ as 'callback + (ReactEvent.Mouse.t -> unit (a:1), [ `Has_arity1 ]) function$ as 'callback type nonrec callback = - (ReactEvent.Mouse.t -> unit as 'u, [ `Has_arity1 ]) function$ + (ReactEvent.Mouse.t -> unit as 'u (a:1), [ `Has_arity1 ]) function$ type nonrec callback = - (ReactEvent.Mouse.t -> unit, [ `Has_arity1 ]) function$ as 'callback \ No newline at end of file + (ReactEvent.Mouse.t -> unit (a:1), [ `Has_arity1 ]) function$ as 'callback \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/alias.res.txt b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/alias.res.txt index 6633a876915..ea7097b7290 100644 --- a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/alias.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/alias.res.txt @@ -1,12 +1,12 @@ type nonrec t = string as 's type nonrec t = _ as 'underscore type nonrec t = parenthesizedType as 'parens -type nonrec t = (int -> unit, [ `Has_arity1 ]) function$ as 'arrow -type nonrec t = (int -> unit as 'unitAlias, [ `Has_arity1 ]) function$ +type nonrec t = (int -> unit (a:1), [ `Has_arity1 ]) function$ as 'arrow +type nonrec t = (int -> unit as 'unitAlias (a:1), [ `Has_arity1 ]) function$ type nonrec t = - (int -> float -> unit, [ `Has_arity2 ]) function$ as 'arrowAlias + (int -> float -> unit (a:2), [ `Has_arity2 ]) function$ as 'arrowAlias type nonrec t = - (int -> float -> unit as 'unitAlias, [ `Has_arity2 ]) function$ + (int -> float -> unit as 'unitAlias (a:2), [ `Has_arity2 ]) function$ type nonrec t = int as 'myNumber type nonrec t = Mod.Sub.t as 'longidentAlias type nonrec t = (int as 'r, int as 'g, int as 'b) color as 'rgb @@ -18,12 +18,13 @@ type nonrec tup = ((int as 'x) * (int as 'y)) as 'tupleAlias let (t : string as 's) = () let (t : _ as 'underscore) = () let (t : parenthesizedType as 'parens) = () -let (t : (int -> unit, [ `Has_arity1 ]) function$ as 'arrow) = () -let (t : (int -> unit as 'unitAlias, [ `Has_arity1 ]) function$) = () -let (t : (int -> float -> unit, [ `Has_arity2 ]) function$ as 'arrowAlias) = - () -let (t : (int -> float -> unit as 'unitAlias, [ `Has_arity2 ]) function$) = +let (t : (int -> unit (a:1), [ `Has_arity1 ]) function$ as 'arrow) = () +let (t : (int -> unit as 'unitAlias (a:1), [ `Has_arity1 ]) function$) = () +let (t : + (int -> float -> unit (a:2), [ `Has_arity2 ]) function$ as 'arrowAlias) = () +let (t : + (int -> float -> unit as 'unitAlias (a:2), [ `Has_arity2 ]) function$) = () let (t : int as 'myNumber) = () let (t : Mod.Sub.t as 'longidentAlias) = () let (t : (int as 'r, int as 'g, int as 'b) color as 'rgb) = () diff --git a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/es6Arrow.res.txt b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/es6Arrow.res.txt index 3fbf63b11a0..2d1766822b3 100644 --- a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/es6Arrow.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/es6Arrow.res.txt @@ -1,45 +1,49 @@ -type nonrec t = (x -> unit, [ `Has_arity1 ]) function$ -type nonrec t = (x -> unit, [ `Has_arity1 ]) function$ -type nonrec t = (int -> string -> unit, [ `Has_arity2 ]) function$ +type nonrec t = (x -> unit (a:1), [ `Has_arity1 ]) function$ +type nonrec t = (x -> unit (a:1), [ `Has_arity1 ]) function$ +type nonrec t = (int -> string -> unit (a:2), [ `Has_arity2 ]) function$ type nonrec t = - (a:((int)[@res.namedArgLoc ]) -> b:((int)[@res.namedArgLoc ]) -> int, + (a:((int)[@res.namedArgLoc ]) -> b:((int)[@res.namedArgLoc ]) -> int (a:2), [ `Has_arity2 ]) function$ type nonrec t = - (?a:((int)[@res.namedArgLoc ]) -> ?b:((int)[@res.namedArgLoc ]) -> int, + (?a:((int)[@res.namedArgLoc ]) -> + ?b:((int)[@res.namedArgLoc ]) -> int (a:2), [ `Has_arity2 ]) function$ type nonrec t = (int -> - (int -> (int -> int, [ `Has_arity1 ]) function$, [ `Has_arity1 ]) - function$, + (int -> (int -> int (a:1), [ `Has_arity1 ]) function$ (a:1), + [ `Has_arity1 ]) function$ (a:1), [ `Has_arity1 ]) function$ type nonrec t = (a:((int)[@res.namedArgLoc ]) -> (b:((int)[@res.namedArgLoc ]) -> - (c:((int)[@res.namedArgLoc ]) -> int, [ `Has_arity1 ]) function$, - [ `Has_arity1 ]) function$, + (c:((int)[@res.namedArgLoc ]) -> int (a:1), [ `Has_arity1 ]) + function$ (a:1), + [ `Has_arity1 ]) function$ (a:1), [ `Has_arity1 ]) function$ -let (f : (x -> unit, [ `Has_arity1 ]) function$) = xf -let (f : (x -> unit, [ `Has_arity1 ]) function$) = xf -let (f : (int -> string -> unit, [ `Has_arity2 ]) function$) = xf +let (f : (x -> unit (a:1), [ `Has_arity1 ]) function$) = xf +let (f : (x -> unit (a:1), [ `Has_arity1 ]) function$) = xf +let (f : (int -> string -> unit (a:2), [ `Has_arity2 ]) function$) = xf let (t : - (a:((int)[@res.namedArgLoc ]) -> b:((int)[@res.namedArgLoc ]) -> int, + (a:((int)[@res.namedArgLoc ]) -> b:((int)[@res.namedArgLoc ]) -> int (a:2), [ `Has_arity2 ]) function$) = xf let (t : - (?a:((int)[@res.namedArgLoc ]) -> ?b:((int)[@res.namedArgLoc ]) -> int, + (?a:((int)[@res.namedArgLoc ]) -> + ?b:((int)[@res.namedArgLoc ]) -> int (a:2), [ `Has_arity2 ]) function$) = xf let (t : (int -> - (int -> (int -> int, [ `Has_arity1 ]) function$, [ `Has_arity1 ]) - function$, + (int -> (int -> int (a:1), [ `Has_arity1 ]) function$ (a:1), + [ `Has_arity1 ]) function$ (a:1), [ `Has_arity1 ]) function$) = xf let (t : (a:((int)[@res.namedArgLoc ]) -> (b:((int)[@res.namedArgLoc ]) -> - (c:((int)[@res.namedArgLoc ]) -> int, [ `Has_arity1 ]) function$, - [ `Has_arity1 ]) function$, + (c:((int)[@res.namedArgLoc ]) -> int (a:1), [ `Has_arity1 ]) + function$ (a:1), + [ `Has_arity1 ]) function$ (a:1), [ `Has_arity1 ]) function$) = xf type nonrec t = f:((int)[@res.namedArgLoc ]) -> string @@ -47,31 +51,31 @@ type nonrec t = ?f:((int)[@res.namedArgLoc ]) -> string let (f : f:((int)[@res.namedArgLoc ]) -> string) = fx let (f : ?f:((int)[@res.namedArgLoc ]) -> string) = fx type nonrec t = - (f:((int)[@res.namedArgLoc ]) -> string, [ `Has_arity1 ]) function$ + (f:((int)[@res.namedArgLoc ]) -> string (a:1), [ `Has_arity1 ]) function$ type nonrec t = f:((int)[@res.namedArgLoc ]) -> string type nonrec t = - (f:(((int -> string, [ `Has_arity1 ]) function$)[@res.namedArgLoc ]) -> - float, + (f:(((int -> string (a:1), [ `Has_arity1 ]) function$)[@res.namedArgLoc ]) + -> float (a:1), [ `Has_arity1 ]) function$ type nonrec t = - f:(((int -> string, [ `Has_arity1 ]) function$)[@res.namedArgLoc ]) -> - float + f:(((int -> string (a:1), [ `Has_arity1 ]) function$)[@res.namedArgLoc ]) + -> float type nonrec t = f:((int)[@res.namedArgLoc ]) -> - (string -> float, [ `Has_arity1 ]) function$ + (string -> float (a:1), [ `Has_arity1 ]) function$ type nonrec t = (((a:((int)[@res.namedArgLoc ]) -> ((b:((int)[@res.namedArgLoc ]) -> ((float)[@attr ]) -> unit)[@attrBeforeLblB - ])) + ]) (a:3)) [@attrBeforeLblA ]), [ `Has_arity3 ]) function$ type nonrec t = (((a:((int)[@res.namedArgLoc ]) -> (((b:((int)[@res.namedArgLoc ]) -> - (((float)[@attr ]) -> unit, [ `Has_arity1 ]) function$, - [ `Has_arity1 ]) function$)[@attrBeforeLblB ]), + (((float)[@attr ]) -> unit (a:1), [ `Has_arity1 ]) function$ (a:1), + [ `Has_arity1 ]) function$)[@attrBeforeLblB ]) (a:1), [ `Has_arity1 ]) function$)[@attrBeforeLblA ]) type nonrec t = ((a:((int)[@res.namedArgLoc ]) -> unit)[@attr ]) type nonrec 'a getInitialPropsFn = (< query: string dict ;req: 'a Js.t Js.Nullable.t > -> - 'a Js.t Js.Promise.t, + 'a Js.t Js.Promise.t (a:1), [ `Has_arity1 ]) function$ \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/firstClassModules.res.txt b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/firstClassModules.res.txt index 447d0726674..55631f94828 100644 --- a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/firstClassModules.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/firstClassModules.res.txt @@ -2,8 +2,8 @@ type nonrec t = (module Hashmap) type nonrec t = (module Hashmap with type key = string) type nonrec t = (module Hashmap with type key = string and type value = int) type nonrec toValueLikeInstance = - ('a t -> (module RxValueLikeInstance.S with type a = 'a), [ `Has_arity1 ]) - function$ + ('a t -> (module RxValueLikeInstance.S with type a = 'a) (a:1), + [ `Has_arity1 ]) function$ type nonrec 'a t = (module Test with type a = 'a) type nonrec t = (module Console) ref let (devices : (string, (module DEVICE)) Hastbl.t) = Hashtbl.creat 17 \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/objectTypeSpreading.res.txt b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/objectTypeSpreading.res.txt index fc276bf314a..822be0d9b04 100644 --- a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/objectTypeSpreading.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/objectTypeSpreading.res.txt @@ -3,10 +3,12 @@ type nonrec u = < a ;u: int > type nonrec v = < v: int ;a > type nonrec w = < j: int ;a ;k: int ;v > type nonrec t = < a ;u: int > as 'a -type nonrec t = (< a ;u: int > -> unit, [ `Has_arity1 ]) function$ -type nonrec t = ((< a ;u: int > as 'a) -> unit, [ `Has_arity1 ]) function$ +type nonrec t = (< a ;u: int > -> unit (a:1), [ `Has_arity1 ]) function$ type nonrec t = - (< a ;u: int > -> < a ;v: int > -> unit, [ `Has_arity2 ]) function$ + ((< a ;u: int > as 'a) -> unit (a:1), [ `Has_arity1 ]) function$ +type nonrec t = + (< a ;u: int > -> < a ;v: int > -> unit (a:2), [ `Has_arity2 ]) + function$ type nonrec user = < name: string > let (steve : < user ;age: int > ) = [%obj { name = {js|Steve|js}; age = 30 }] diff --git a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/parenthesized.res.txt b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/parenthesized.res.txt index 8c63ded5b0d..29e94bf43eb 100644 --- a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/parenthesized.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/parenthesized.res.txt @@ -1,3 +1,3 @@ type nonrec t = - (((a:((int)[@res.namedArgLoc ]) -> unit, [ `Has_arity1 ]) function$) + (((a:((int)[@res.namedArgLoc ]) -> unit (a:1), [ `Has_arity1 ]) function$) [@attr ]) \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/poly.res.txt b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/poly.res.txt index 541ac452276..242afda0d69 100644 --- a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/poly.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/poly.res.txt @@ -1,10 +1,20 @@ external getLogger : (unit -> < - log: ('a -> unit, [ `Has_arity1 ]) function$ ;log2: 'a . - (int -> int, - [ - `Has_arity1 ]) - function$ ; - log3: 'a 'b . ('a -> 'b -> int, [ `Has_arity2 ]) function$ > , + log: ('a -> unit (a:1), [ `Has_arity1 ]) function$ ;log2: 'a . + (int -> + int (a:1), + [ + `Has_arity1 + ]) + function$ + ;log3: + 'a 'b . + ('a -> + 'b -> int (a:2), + [ + `Has_arity2 + ]) + function$ + > (a:1), [ `Has_arity1 ]) function$ = "./src/logger.mock.js" \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/polyVariant.res.txt b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/polyVariant.res.txt index d268ca5a8f1..17d57db28a4 100644 --- a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/polyVariant.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/polyVariant.res.txt @@ -4,13 +4,15 @@ module type Conjunctive = type nonrec u1 = [ `A | `B ] type nonrec u2 = [ `A | `B | `C ] val f : - ([< `T of [< u2]&[< u2]&[< u1] ] -> unit, [ `Has_arity1 ]) function$ + ([< `T of [< u2]&[< u2]&[< u1] ] -> unit (a:1), [ `Has_arity1 ]) + function$ val g : - ([< `S of [< u2]&[< u2]&[< u1] ] -> unit, [ `Has_arity1 ]) function$ + ([< `S of [< u2]&[< u2]&[< u1] ] -> unit (a:1), [ `Has_arity1 ]) + function$ val g : ([< `Exotic-S+ of [< `Exotic-u2+ ]&[< `Exotic-u2- ]&[< `Exotic-u1+++ ] ] - -> unit, + -> unit (a:1), [ `Has_arity1 ]) function$ end type nonrec t = [ s] diff --git a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/uncurried.res.txt b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/uncurried.res.txt index bf6ecb648d7..742dab6a282 100644 --- a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/uncurried.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/uncurried.res.txt @@ -1,25 +1,28 @@ type nonrec t = { - mutable field: (float -> int -> bool -> unit, [ `Has_arity3 ]) function$ } -type nonrec t = (float -> int -> bool -> unit, [ `Has_arity3 ]) function$ + mutable field: + (float -> int -> bool -> unit (a:3), [ `Has_arity3 ]) function$ } +type nonrec t = + (float -> int -> bool -> unit (a:3), [ `Has_arity3 ]) function$ type nonrec t = (((float)[@attr ]) -> - ((int)[@attr2 ]) -> ((bool)[@attr3 ]) -> ((string)[@attr4 ]) -> unit, + ((int)[@attr2 ]) -> ((bool)[@attr3 ]) -> ((string)[@attr4 ]) -> unit (a:4), [ `Has_arity4 ]) function$ type nonrec t = (((float -> (((int)[@attr2 ]) -> - (((bool -> (((string)[@attr4 ]) -> unit, [ `Has_arity1 ]) function$, - [ `Has_arity1 ]) function$)[@attr3 ]), - [ `Has_arity1 ]) function$, + (((bool -> + (((string)[@attr4 ]) -> unit (a:1), [ `Has_arity1 ]) function$ (a:1), + [ `Has_arity1 ]) function$)[@attr3 ]) (a:1), + [ `Has_arity1 ]) function$ (a:1), [ `Has_arity1 ]) function$)[@attr ]) type nonrec t = (((float)[@attr ]) -> - ((int)[@attr2 ]) -> ((bool)[@attr3 ]) -> ((string)[@attr4 ]) -> unit, + ((int)[@attr2 ]) -> ((bool)[@attr3 ]) -> ((string)[@attr4 ]) -> unit (a:4), [ `Has_arity4 ]) function$ external setTimeout : - ((unit -> unit, [ `Has_arity1 ]) function$ -> int -> timerId, + ((unit -> unit (a:1), [ `Has_arity1 ]) function$ -> int -> timerId (a:2), [ `Has_arity2 ]) function$ = "setTimeout"[@@val ] external setTimeout : - ((unit -> unit, [ `Has_arity1 ]) function$ -> int -> timerId, + ((unit -> unit (a:1), [ `Has_arity1 ]) function$ -> int -> timerId (a:2), [ `Has_arity2 ]) function$ = "setTimeout" \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/unit.res.txt b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/unit.res.txt index dd25f830785..10891245b54 100644 --- a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/unit.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/unit.res.txt @@ -1,10 +1,11 @@ type nonrec t = unit -type nonrec t = (unit -> unit, [ `Has_arity1 ]) function$ -type nonrec t = (unit -> unit -> unit, [ `Has_arity2 ]) function$ -type nonrec t = (unit -> unit, [ `Has_arity1 ]) function$ -let f [arity:1](f : (unit -> unit, [ `Has_arity1 ]) function$) = f () -let f [arity:1](f : (unit -> unit, [ `Has_arity1 ]) function$) = f () -let f [arity:1](f : (unit -> unit -> unit, [ `Has_arity2 ]) function$) = - f () () -external svg : (unit -> React.element, [ `Has_arity1 ]) function$ = "svg" -external thing : (unit -> unit, [ `Has_arity1 ]) function$ = "svg" \ No newline at end of file +type nonrec t = (unit -> unit (a:1), [ `Has_arity1 ]) function$ +type nonrec t = (unit -> unit -> unit (a:2), [ `Has_arity2 ]) function$ +type nonrec t = (unit -> unit (a:1), [ `Has_arity1 ]) function$ +let f [arity:1](f : (unit -> unit (a:1), [ `Has_arity1 ]) function$) = f () +let f [arity:1](f : (unit -> unit (a:1), [ `Has_arity1 ]) function$) = f () +let f [arity:1](f : (unit -> unit -> unit (a:2), [ `Has_arity2 ]) function$) + = f () () +external svg : + (unit -> React.element (a:1), [ `Has_arity1 ]) function$ = "svg" +external thing : (unit -> unit (a:1), [ `Has_arity1 ]) function$ = "svg" \ No newline at end of file diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 0048087e0de..61aabc07553 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -395,7 +395,7 @@ let valueDetail (typ : Types.type_expr) = collectSignatureTypes t.desc) in [{path = p; genericParameters = ts}]) - | Tarrow (_, t1, t2, _) -> + | Tarrow (_, t1, t2, _, _) -> collectSignatureTypes t1.desc @ collectSignatureTypes t2.desc | Tvar None -> [{path = "_"; genericParameters = []}] | _ -> [] From 53b9824926a55ffff013bf3009076bd607860460 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 16 Dec 2024 20:40:51 +0100 Subject: [PATCH 4/9] Fix uncurried function type handling in FFI and type system Fix uncurried function type handling in FFI and type system This commit improves handling of uncurried function types, particularly in FFI and the type system: - Add arity information to @obj externals by returning arity from process_obj - Fix filter_arrow to properly handle arity in type unification - Remove invalid assert false in ast_uncurried.ml - Update type_function and type_application to properly handle arity information - Pass arity through to is_ignore function for consistent type checking These changes help ensure proper type checking and arity handling for uncurried functions, especially in FFI bindings using @obj. --- compiler/frontend/ast_external_process.ml | 15 ++++++++++----- compiler/ml/ast_uncurried.ml | 1 - compiler/ml/ctype.ml | 6 ++---- compiler/ml/ctype.mli | 3 ++- compiler/ml/typecore.ml | 20 +++++++++++--------- 5 files changed, 25 insertions(+), 20 deletions(-) diff --git a/compiler/frontend/ast_external_process.ml b/compiler/frontend/ast_external_process.ml index 24824f9839c..7d7d82c64af 100644 --- a/compiler/frontend/ast_external_process.ml +++ b/compiler/frontend/ast_external_process.ml @@ -426,8 +426,8 @@ type response = { let process_obj (loc : Location.t) (st : external_desc) (prim_name : string) (arg_types_ty : Ast_core_type.param_type list) - (result_type : Ast_core_type.t) : Parsetree.core_type * External_ffi_types.t - = + (result_type : Ast_core_type.t) : + int * Parsetree.core_type * External_ffi_types.t = match st with | { val_name = None; @@ -610,7 +610,9 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string) (* TODO: do we need do some error checking here *) (* result type can not be labeled *) in - ( Ast_core_type.mk_fn_type new_arg_types_ty result, + + ( List.length new_arg_types_ty, + Ast_core_type.mk_fn_type new_arg_types_ty result, External_ffi_types.ffi_obj_create arg_kinds ) | _ -> Location.raise_errorf ~loc "Attribute found that conflicts with %@obj" @@ -961,10 +963,13 @@ let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type) in if external_desc.mk_obj then (* warn unused attributes here ? *) - let new_type, spec = + let arity, new_type, spec = process_obj loc external_desc prim_name arg_types_ty result_type in - (build_uncurried_type ~arity:None new_type, spec, unused_attrs, false) + ( build_uncurried_type ~arity:(Some arity) new_type, + spec, + unused_attrs, + false ) else let splice = external_desc.splice in let arg_type_specs, new_arg_types_ty, arg_type_specs_length = diff --git a/compiler/ml/ast_uncurried.ml b/compiler/ml/ast_uncurried.ml index ff678709077..e5f573da551 100644 --- a/compiler/ml/ast_uncurried.ml +++ b/compiler/ml/ast_uncurried.ml @@ -96,7 +96,6 @@ let make_uncurried_type ~env ~arity (t : Types.type_expr) = let t = match t.desc with | Tarrow (l, t1, t2, c, _) -> - let _ = assert false in {t with desc = Tarrow (l, t1, t2, c, Some arity)} | Tconstr _ -> assert false | Tvar _ -> t diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index e3cf10c61c6..10787b8c44a 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -2758,15 +2758,13 @@ let expand_head_trace env t = (2) the original label is not optional *) -let filter_arrow env t l = +let filter_arrow ~env ~arity t l = let t = expand_head_trace env t in match t.desc with | Tvar _ -> - let _ = assert false in - (* TODO: need the arity from the function definition *) let lv = t.level in let t1 = newvar2 lv and t2 = newvar2 lv in - let t' = newty2 lv (Tarrow (l, t1, t2, Cok, None)) in + let t' = newty2 lv (Tarrow (l, t1, t2, Cok, arity)) in link_type t t'; (t1, t2) | Tarrow (l', t1, t2, _, _) when Asttypes.same_arg_label l l' -> (t1, t2) diff --git a/compiler/ml/ctype.mli b/compiler/ml/ctype.mli index b231dc61acc..207b54b6db0 100644 --- a/compiler/ml/ctype.mli +++ b/compiler/ml/ctype.mli @@ -203,7 +203,8 @@ val unify_var : Env.t -> type_expr -> type_expr -> unit val with_passive_variants : ('a -> 'b) -> 'a -> 'b (* Call [f] in passive_variants mode, for exhaustiveness check. *) -val filter_arrow : Env.t -> type_expr -> arg_label -> type_expr * type_expr +val filter_arrow : + env:Env.t -> arity:arity -> type_expr -> arg_label -> type_expr * type_expr (* A special case of unification (with l:'a -> 'b). *) val filter_method : Env.t -> string -> private_flag -> type_expr -> type_expr diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index e7f14719d28..3d80bc98187 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -2225,12 +2225,12 @@ let unify_exp ?type_clash_context env exp expected_ty = let loc = proper_exp_loc exp in unify_exp_types ?type_clash_context loc env exp.exp_type expected_ty -let is_ignore funct env = +let is_ignore ~env ~arity funct = match funct.exp_desc with | Texp_ident (_, _, {val_kind = Val_prim {Primitive.prim_name = "%ignore"}}) -> ( try - ignore (filter_arrow env (instance env funct.exp_type) Nolabel); + ignore (filter_arrow ~env ~arity (instance env funct.exp_type) Nolabel); true with Unify _ -> false) | _ -> false @@ -3281,7 +3281,7 @@ and type_function ?in_function ~arity loc attrs env ty_expected_ l caselist = let separate = Env.has_local_constraints env in if separate then begin_def (); let ty_arg, ty_res = - try filter_arrow env (instance env ty_expected) l + try filter_arrow ~env ~arity (instance env ty_expected) l with Unify _ -> ( match expand_head env ty_expected with | {desc = Tarrow _} as ty -> @@ -3310,7 +3310,9 @@ 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, assert false))) in + let exp_type = + instance env (newgenty (Tarrow (l, ty_arg, ty_res, Cok, arity))) + in let exp_type = match arity with | None -> exp_type @@ -3718,11 +3720,14 @@ and type_application ?type_clash_context uncurried env funct (sargs : sargs) : (List.map Printtyp.string_of_label (Ext_list.filter labels (fun x -> x <> Nolabel))) )) in + if uncurried then force_uncurried_type funct; + let ty, max_arity = extract_uncurried_type funct.exp_type in + let top_arity = if uncurried then Some max_arity else None in match sargs with (* Special case for ignore: avoid discarding warning *) - | [(Nolabel, sarg)] when is_ignore funct env -> + | [(Nolabel, sarg)] when is_ignore ~env ~arity:top_arity funct -> let ty_arg, ty_res = - filter_arrow env (instance env funct.exp_type) Nolabel + filter_arrow ~env ~arity:top_arity (instance env funct.exp_type) Nolabel in let exp = type_expect env sarg ty_arg in (match (expand_head env exp.exp_type).desc with @@ -3734,9 +3739,6 @@ and type_application ?type_clash_context uncurried env funct (sargs : sargs) : | _ -> ()); ([(Nolabel, Some exp)], ty_res, false) | _ -> - if uncurried then force_uncurried_type funct; - let ty, max_arity = extract_uncurried_type funct.exp_type in - let top_arity = if uncurried then Some max_arity else None in let targs, ret_t = type_args ?type_clash_context max_arity [] [] ~ty_fun:ty (instance env ty) ~sargs ~top_arity From c0260ea721888ad68400e08e530d95d7c0a98833 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 16 Dec 2024 20:44:42 +0100 Subject: [PATCH 5/9] Update TestPpx.res.jsout --- tests/tools_tests/src/expected/TestPpx.res.jsout | 1 + 1 file changed, 1 insertion(+) diff --git a/tests/tools_tests/src/expected/TestPpx.res.jsout b/tests/tools_tests/src/expected/TestPpx.res.jsout index 819d3cf4ec0..8235042c401 100644 --- a/tests/tools_tests/src/expected/TestPpx.res.jsout +++ b/tests/tools_tests/src/expected/TestPpx.res.jsout @@ -38,6 +38,7 @@ React.useState(() => 0); async function fpromise(promise, _x) { return await promise; } + let Uncurried = {}; let a = "A"; From 5d0977a187170bb35d5aeeaeef6244cd500b45c4 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 18 Dec 2024 10:09:16 +0100 Subject: [PATCH 6/9] Remove remaining uses of `type_to_arity`. --- compiler/ml/ast_uncurried.ml | 20 +++++++------ compiler/ml/ctype.ml | 9 +++--- compiler/ml/printtyp.ml | 11 +++++-- compiler/ml/typecore.ml | 58 +++++++++++++++++++++++------------- 4 files changed, 62 insertions(+), 36 deletions(-) diff --git a/compiler/ml/ast_uncurried.ml b/compiler/ml/ast_uncurried.ml index e5f573da551..f464026fbde 100644 --- a/compiler/ml/ast_uncurried.ml +++ b/compiler/ml/ast_uncurried.ml @@ -78,16 +78,18 @@ let arity_to_type arity = row_name = None; }) -let type_to_arity (t_arity : Types.type_expr) = - match (Ctype.repr t_arity).desc with - | Tvariant {row_fields = [(label, _)]} -> decode_arity_string label - | _ -> assert false - -let fun_type_to_arity (t_arity : Types.type_expr) = +let tarrow_to_arity (t_arity : Types.type_expr) = match (Ctype.repr t_arity).desc with | Tarrow (_, _, _, _, Some arity) -> arity | Tarrow _ -> assert false - | _ -> 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 make_uncurried_type ~env ~arity (t : Types.type_expr) = let typ_arity = arity_to_type arity in @@ -105,11 +107,11 @@ let make_uncurried_type ~env ~arity (t : Types.type_expr) = let uncurried_type_get_arity ~env typ = match (Ctype.expand_head env typ).desc with - | Tconstr (Pident {name = "function$"}, [t; _arity], _) -> fun_type_to_arity t + | Tconstr (Pident {name = "function$"}, [t; _arity], _) -> tarrow_to_arity t | _ -> assert false let uncurried_type_get_arity_opt ~env typ = match (Ctype.expand_head env typ).desc with | Tconstr (Pident {name = "function$"}, [t; _arity], _) -> - Some (fun_type_to_arity t) + Some (tarrow_to_arity t) | _ -> None diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index 10787b8c44a..b01853f2d67 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -2310,10 +2310,11 @@ and unify3 env t1 t1' t2 t2' = | Pattern -> add_type_equality t1' t2'); try (match (d1, d2) with - | Tarrow (l1, t1, u1, c1, _), Tarrow (l2, t2, u2, c2, _) - when Asttypes.same_arg_label l1 l2 - || (!umode = Pattern && not (is_optional l1 || is_optional l2)) - -> ( + | Tarrow (l1, t1, u1, c1, a1), Tarrow (l2, t2, u2, c2, a2) + when a1 = a2 + && (Asttypes.same_arg_label l1 l2 + || (!umode = Pattern && not (is_optional l1 || is_optional l2)) + ) -> ( unify env t1 t2; unify env u1 u2; match (commu_repr c1, commu_repr c2) with diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index 6a796d54a1b..ab990159e7b 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -146,6 +146,10 @@ let string_of_label = function | Labelled s -> s | Optional s -> "?" ^ s +let string_of_arity = function + | None -> "" + | Some arity -> string_of_int arity + let visited = ref [] let rec raw_type ppf ty = let ty = safe_repr [] ty in @@ -159,9 +163,10 @@ and raw_type_list tl = raw_list raw_type tl and raw_type_desc ppf = function | Tvar name -> fprintf ppf "Tvar %a" print_name name - | Tarrow (l, t1, t2, c, _) -> - fprintf ppf "@[Tarrow(\"%s\",@,%a,@,%a,@,%s)@]" (string_of_label l) - raw_type t1 raw_type t2 (safe_commu_repr [] c) + | Tarrow (l, t1, t2, c, a) -> + fprintf ppf "@[Tarrow(\"%s\",@,%a,@,%a,@,%s,@,%s)@]" + (string_of_label l) raw_type t1 raw_type t2 (safe_commu_repr [] c) + (string_of_arity a) | Ttuple tl -> fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl | Tconstr (p, tl, abbrev) -> fprintf ppf "@[Tconstr(@,%a,@,%a,@,%a)@]" path p raw_type_list tl diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 3d80bc98187..8147d8b3c38 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -315,8 +315,6 @@ let unify_pat_types loc env ty ty' = (* unification inside type_exp and type_expect *) let unify_exp_types ?type_clash_context loc env ty expected_ty = - (* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type - Printtyp.raw_type_expr expected_ty; *) try unify env ty expected_ty with | Unify trace -> raise (Error (loc, env, Expr_type_clash (trace, type_clash_context))) @@ -3268,7 +3266,7 @@ and type_function ?in_function ~arity loc attrs env ty_expected_ l caselist = match arity with | None -> ty_expected_ | Some arity -> - let fun_t = newvar () in + let fun_t = newty (Tarrow (l, newvar (), newvar (), Cok, Some arity)) 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 @@ -3519,7 +3517,6 @@ and translate_unified_ops (env : Env.t) (funct : Typedtree.expression) and type_application ?type_clash_context uncurried env funct (sargs : sargs) : targs * Types.type_expr * bool = - (* funct.exp_type may be generic *) let result_type omitted ty_fun = List.fold_left (fun ty_fun (l, ty, lv) -> newty2 lv (Tarrow (l, ty, ty_fun, Cok, None))) @@ -3530,15 +3527,20 @@ and type_application ?type_clash_context uncurried env funct (sargs : sargs) : tvar || List.mem l ls in let ignored = ref [] in - let has_uncurried_type t = + let has_uncurried_type funct = + let t = funct.exp_type in match (expand_head env t).desc with - | Tconstr (Pident {name = "function$"}, [t; t_arity], _) -> - let arity = Ast_uncurried.type_to_arity t_arity in + | Tconstr (Pident {name = "function$"}, [t; _t_arity], _) -> + let arity = + match Ast_uncurried.tarrow_to_arity_opt t with + | Some arity -> arity + | None -> List.length sargs + in Some (arity, t) | _ -> None in let force_uncurried_type funct = - match has_uncurried_type funct.exp_type with + match has_uncurried_type funct with | None -> ( let arity = List.length sargs in let uncurried_typ = @@ -3554,8 +3556,9 @@ and type_application ?type_clash_context uncurried env funct (sargs : sargs) : Apply_non_function (expand_head env funct.exp_type) ))) | Some _ -> () in - let extract_uncurried_type t = - match has_uncurried_type t with + let extract_uncurried_type funct = + let t = funct.exp_type in + match has_uncurried_type funct with | Some (arity, t1) -> if List.length sargs > arity then raise @@ -3566,8 +3569,8 @@ and type_application ?type_clash_context uncurried env funct (sargs : sargs) : (t1, arity) | None -> (t, max_int) in - let update_uncurried_arity ~nargs t new_t = - match has_uncurried_type t with + let update_uncurried_arity ~nargs funct new_t = + match has_uncurried_type funct with | Some (arity, _) -> let newarity = arity - nargs in let fully_applied = newarity <= 0 in @@ -3576,7 +3579,8 @@ and type_application ?type_clash_context uncurried env funct (sargs : sargs) : (Error ( funct.exp_loc, env, - Uncurried_arity_mismatch (t, arity, List.length sargs) )); + Uncurried_arity_mismatch + (funct.exp_type, arity, List.length sargs) )); let new_t = if fully_applied then new_t else Ast_uncurried.make_uncurried_type ~env ~arity:newarity new_t @@ -3721,7 +3725,7 @@ and type_application ?type_clash_context uncurried env funct (sargs : sargs) : (Ext_list.filter labels (fun x -> x <> Nolabel))) )) in if uncurried then force_uncurried_type funct; - let ty, max_arity = extract_uncurried_type funct.exp_type in + let ty, max_arity = extract_uncurried_type funct in let top_arity = if uncurried then Some max_arity else None in match sargs with (* Special case for ignore: avoid discarding warning *) @@ -3744,7 +3748,7 @@ and type_application ?type_clash_context uncurried env funct (sargs : sargs) : ~sargs ~top_arity in let fully_applied, ret_t = - update_uncurried_arity funct.exp_type + update_uncurried_arity funct ~nargs:(List.length !ignored + List.length sargs) ret_t in @@ -4340,13 +4344,27 @@ let report_error env ppf = function "This function is an uncurried function where a curried function is \ expected" | Expr_type_clash - ( (_, {desc = Tconstr (Pident {name = "function$"}, [_; t_a], _)}) - :: (_, {desc = Tconstr (Pident {name = "function$"}, [_; t_b], _)}) + ( ( _, + { + desc = + Tconstr + ( Pident {name = "function$"}, + [{desc = Tarrow (_, _, _, _, Some arity_a)}; _], + _ ); + } ) + :: ( _, + { + desc = + Tconstr + ( Pident {name = "function$"}, + [{desc = Tarrow (_, _, _, _, Some arity_b)}; _], + _ ); + } ) :: _, _ ) - when Ast_uncurried.type_to_arity t_a <> Ast_uncurried.type_to_arity t_b -> - let arity_a = Ast_uncurried.type_to_arity t_a |> string_of_int in - let arity_b = Ast_uncurried.type_to_arity t_b |> string_of_int in + when arity_a <> arity_b -> + let arity_a = arity_a |> string_of_int in + let arity_b = arity_b |> string_of_int in report_arity_mismatch ~arity_a ~arity_b ppf | Expr_type_clash ( ( _, From d647c996c47984e82f4019260d6a0d0b5a721d94 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 18 Dec 2024 10:20:37 +0100 Subject: [PATCH 7/9] Move arity decoding to ast conversion. --- compiler/ml/ast_mapper_from0.ml | 12 +++++++++++- compiler/ml/ast_uncurried.ml | 14 ++++---------- 2 files changed, 15 insertions(+), 11 deletions(-) diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index 91cb6a809bf..60f94866ebd 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -109,7 +109,17 @@ module T = struct | Ptyp_constr (lid, [({ptyp_desc = Ptyp_arrow (lbl, t1, t2, _)} as fun_t); t_arity]) when lid.txt = Lident "function$" -> - let arity = Ast_uncurried.arity_from_type t_arity in + let decode_arity_string arity_s = + int_of_string + ((String.sub [@doesNotRaise]) arity_s 9 (String.length arity_s - 9)) + in + let arity_from_type (typ : Parsetree.core_type) = + match typ.ptyp_desc with + | Ptyp_variant ([Rtag ({txt}, _, _, _)], _, _) -> + decode_arity_string txt + | _ -> assert false + in + let arity = arity_from_type t_arity in let fun_t = {fun_t with ptyp_desc = Ptyp_arrow (lbl, t1, t2, Some arity)} in diff --git a/compiler/ml/ast_uncurried.ml b/compiler/ml/ast_uncurried.ml index f464026fbde..92900e615db 100644 --- a/compiler/ml/ast_uncurried.ml +++ b/compiler/ml/ast_uncurried.ml @@ -1,20 +1,12 @@ (* Uncurried AST *) let encode_arity_string arity = "Has_arity" ^ string_of_int arity -let decode_arity_string arity_s = - int_of_string - ((String.sub [@doesNotRaise]) arity_s 9 (String.length arity_s - 9)) let arity_type ~loc arity = Ast_helper.Typ.variant ~loc [Rtag ({txt = encode_arity_string arity; loc}, [], true, [])] Closed None -let arity_from_type (typ : Parsetree.core_type) = - match typ.ptyp_desc with - | Ptyp_variant ([Rtag ({txt}, _, _, _)], _, _) -> decode_arity_string txt - | _ -> assert false - let uncurried_type ~loc ~arity (t_arg : Parsetree.core_type) = let t_arg = match t_arg.ptyp_desc with @@ -52,8 +44,10 @@ let core_type_is_uncurried_fun (typ : Parsetree.core_type) = let core_type_extract_uncurried_fun (typ : Parsetree.core_type) = match typ.ptyp_desc with - | Ptyp_constr ({txt = Lident "function$"}, [t_arg; t_arity]) -> - (arity_from_type t_arity, t_arg) + | Ptyp_constr + ( {txt = Lident "function$"}, + [({ptyp_desc = Ptyp_arrow (_, _, _, Some arity)} as t_arg); _] ) -> + (arity, t_arg) | _ -> assert false let type_is_uncurried_fun = Ast_uncurried_utils.type_is_uncurried_fun From 45ce228693dffbb2ae98df0323db299e4c5b53bd Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 18 Dec 2024 11:42:59 +0100 Subject: [PATCH 8/9] Remove the arity parameter of type `function$`. --- analysis/src/CompletionBackEnd.ml | 2 +- analysis/src/CompletionJsx.ml | 2 +- analysis/src/CreateInterface.ml | 2 +- analysis/src/SignatureHelp.ml | 2 +- analysis/src/TypeUtils.ml | 10 +- compiler/frontend/ast_core_type_class_type.ml | 2 +- compiler/frontend/ast_external_process.ml | 9 +- .../gentype/TranslateTypeExprFromTypes.ml | 3 +- compiler/ml/ast_mapper_from0.ml | 2 +- compiler/ml/ast_mapper_to0.ml | 11 + compiler/ml/ast_uncurried.ml | 37 +--- compiler/ml/ast_uncurried_utils.ml | 2 +- compiler/ml/ctype.ml | 2 +- compiler/ml/predef.ml | 8 +- compiler/ml/typecore.ml | 11 +- compiler/syntax/src/res_comments_table.ml | 2 +- compiler/syntax/src/res_outcome_printer.ml | 9 +- .../other/expected/labelledParameters.res.txt | 2 +- .../other/expected/regionMissingComma.res.txt | 4 +- .../structure/expected/external.res.txt | 3 +- .../typeDef/expected/inlineRecord.res.txt | 4 +- .../typeDef/expected/namedParameters.res.txt | 2 +- .../typeDef/expected/typeParams.res.txt | 8 +- .../errors/typexpr/expected/arrow.res.txt | 7 +- .../typexpr/expected/bsObjSugar.res.txt | 4 +- .../errors/typexpr/expected/garbage.res.txt | 4 +- .../expected/UncurriedByDefault.res.txt | 190 +++++++----------- .../expressions/expected/arrow.res.txt | 2 +- .../expressions/expected/block.res.txt | 4 +- .../expected/locallyAbstractTypes.res.txt | 4 +- .../grammar/modexpr/expected/functor.res.txt | 6 +- .../modtype/expected/parenthesized.res.txt | 6 +- .../grammar/modtype/expected/typeof.res.txt | 6 +- .../grammar/modtype/expected/with.res.txt | 8 +- .../signature/expected/external.res.txt | 13 +- .../signature/expected/recModule.res.txt | 4 +- .../expected/externalDefinition.res.txt | 20 +- .../expected/constructorDeclaration.res.txt | 13 +- .../expected/privateTypeEquation.res.txt | 11 +- .../expected/typeInformation.res.txt | 7 +- .../grammar/typexpr/expected/alias.res.txt | 21 +- .../grammar/typexpr/expected/es6Arrow.res.txt | 84 ++++---- .../expected/firstClassModules.res.txt | 3 +- .../expected/objectTypeSpreading.res.txt | 8 +- .../typexpr/expected/parenthesized.res.txt | 3 +- .../grammar/typexpr/expected/poly.res.txt | 22 +- .../typexpr/expected/polyVariant.res.txt | 12 +- .../typexpr/expected/uncurried.res.txt | 31 ++- .../grammar/typexpr/expected/unit.res.txt | 18 +- .../expected/nonRecTypes.res.txt | 23 +-- .../pattern/expected/constrained.res.txt | 4 +- tools/src/tools.ml | 2 +- 52 files changed, 268 insertions(+), 411 deletions(-) diff --git a/analysis/src/CompletionBackEnd.ml b/analysis/src/CompletionBackEnd.ml index 870993800cb..bfbcb4c1b02 100644 --- a/analysis/src/CompletionBackEnd.ml +++ b/analysis/src/CompletionBackEnd.ml @@ -1362,7 +1362,7 @@ let rec completeTypedValue ?(typeArgContext : typeArgContext option) ~rawOpens | Tlink t1 | Tsubst t1 | Tpoly (t1, []) - | Tconstr (Pident {name = "function$"}, [t1; _], _) -> + | Tconstr (Pident {name = "function$"}, [t1], _) -> fnReturnsTypeT t1 | Tarrow _ -> ( match TypeUtils.extractFunctionType ~env ~package:full.package t with diff --git a/analysis/src/CompletionJsx.ml b/analysis/src/CompletionJsx.ml index 466dddb4f79..271d1203b14 100644 --- a/analysis/src/CompletionJsx.ml +++ b/analysis/src/CompletionJsx.ml @@ -238,7 +238,7 @@ let getJsxLabels ~componentPath ~findTypeOfValue ~package = | Tlink t1 | Tsubst t1 | Tpoly (t1, []) - | Tconstr (Pident {name = "function$"}, [t1; _], _) -> + | Tconstr (Pident {name = "function$"}, [t1], _) -> getLabels t1 | Tconstr (p, [propsType], _) when Path.name p = "React.component" -> ( let rec getPropsType (t : Types.type_expr) = diff --git a/analysis/src/CreateInterface.ml b/analysis/src/CreateInterface.ml index d95b87aaea8..5f5cdcf6d96 100644 --- a/analysis/src/CreateInterface.ml +++ b/analysis/src/CreateInterface.ml @@ -123,7 +123,7 @@ let printSignature ~extractor ~signature = Ctype.newconstr (Pdot (Pident (Ident.create "React"), "element", 0)) [] in match typ.desc with - | Tconstr (Pident {name = "function$"}, [typ; _], _) -> getComponentType typ + | Tconstr (Pident {name = "function$"}, [typ], _) -> getComponentType typ | Tarrow (_, {desc = Tconstr (Path.Pident propsId, typeArgs, _)}, retType, _, _) when Ident.name propsId = "props" -> diff --git a/analysis/src/SignatureHelp.ml b/analysis/src/SignatureHelp.ml index 85f6f8fbe78..5d264657c5a 100644 --- a/analysis/src/SignatureHelp.ml +++ b/analysis/src/SignatureHelp.ml @@ -118,7 +118,7 @@ let extractParameters ~signature ~typeStrForParser ~labelPrefixLen = ptyp_desc = Ptyp_constr ( {txt = Lident "function$"}, - [({ptyp_desc = Ptyp_arrow _} as expr); _] ); + [({ptyp_desc = Ptyp_arrow _} as expr)] ); }; }; } ); diff --git a/analysis/src/TypeUtils.ml b/analysis/src/TypeUtils.ml index 3993cebee75..453083889f4 100644 --- a/analysis/src/TypeUtils.ml +++ b/analysis/src/TypeUtils.ml @@ -36,7 +36,7 @@ let findTypeViaLoc ~full ~debug (loc : Location.t) = let rec pathFromTypeExpr (t : Types.type_expr) = match t.desc with - | Tconstr (Pident {name = "function$"}, [t; _], _) -> pathFromTypeExpr t + | Tconstr (Pident {name = "function$"}, [t], _) -> pathFromTypeExpr t | Tconstr (path, _typeArgs, _) | Tlink {desc = Tconstr (path, _typeArgs, _)} | Tsubst {desc = Tconstr (path, _typeArgs, _)} @@ -243,7 +243,7 @@ let rec extractFunctionType ~env ~package typ = match t.desc with | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> loop ~env acc t1 | Tarrow (label, tArg, tRet, _, _) -> loop ~env ((label, tArg) :: acc) tRet - | Tconstr (Pident {name = "function$"}, [t; _], _) -> + | Tconstr (Pident {name = "function$"}, [t], _) -> extractFunctionType ~env ~package t | Tconstr (path, typeArgs, _) -> ( match References.digConstructor ~env ~package path with @@ -283,7 +283,7 @@ let rec extractFunctionType2 ?typeArgContext ~env ~package typ = | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> loop ?typeArgContext ~env acc t1 | Tarrow (label, tArg, tRet, _, _) -> loop ?typeArgContext ~env ((label, tArg) :: acc) tRet - | Tconstr (Pident {name = "function$"}, [t; _], _) -> + | Tconstr (Pident {name = "function$"}, [t], _) -> extractFunctionType2 ?typeArgContext ~env ~package t | Tconstr (path, typeArgs, _) -> ( match References.digConstructor ~env ~package path with @@ -334,7 +334,7 @@ let rec extractType ?(printOpeningDebug = true) Some (Tstring env, typeArgContext) | Tconstr (Path.Pident {name = "exn"}, [], _) -> Some (Texn env, typeArgContext) - | Tconstr (Pident {name = "function$"}, [t; _], _) -> ( + | Tconstr (Pident {name = "function$"}, [t], _) -> ( match extractFunctionType2 ?typeArgContext t ~env ~package with | args, tRet, typeArgContext when args <> [] -> Some @@ -910,7 +910,7 @@ let getArgs ~env (t : Types.type_expr) ~full = | Tlink t1 | Tsubst t1 | Tpoly (t1, []) - | Tconstr (Pident {name = "function$"}, [t1; _], _) -> + | Tconstr (Pident {name = "function$"}, [t1], _) -> getArgsLoop ~full ~env ~currentArgumentPosition t1 | Tarrow (Labelled l, tArg, tRet, _, _) -> (SharedTypes.Completable.Labelled l, tArg) diff --git a/compiler/frontend/ast_core_type_class_type.ml b/compiler/frontend/ast_core_type_class_type.ml index 5b2920a8a7e..495552182bd 100644 --- a/compiler/frontend/ast_core_type_class_type.ml +++ b/compiler/frontend/ast_core_type_class_type.ml @@ -73,7 +73,7 @@ let typ_mapper (self : Bs_ast_mapper.mapper) (ty : Parsetree.core_type) = | Ptyp_constr (* function$<...> is re-wrapped around only in case Nothing below *) ( {txt = Lident "function$"}, - [{ptyp_desc = Ptyp_arrow (label, args, body, _)}; _] ) ); + [{ptyp_desc = Ptyp_arrow (label, args, 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 7d7d82c64af..7f453335e04 100644 --- a/compiler/frontend/ast_external_process.ml +++ b/compiler/frontend/ast_external_process.ml @@ -935,21 +935,16 @@ 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.ptyp_desc with - | Ptyp_constr (({txt = Lident "function$"; _} as lid), [t; arity_]) -> + | Ptyp_constr (({txt = Lident "function$"; _} as lid), [t]) -> ( t, fun ~arity (x : Parsetree.core_type) -> - let t_arity = - match arity with - | Some arity -> Ast_uncurried.arity_type ~loc arity - | None -> arity_ - in let x = match x.ptyp_desc with | Ptyp_arrow (l, t1, t2, _) -> {x with ptyp_desc = Ptyp_arrow (l, t1, t2, arity)} | _ -> x in - {x with Parsetree.ptyp_desc = Ptyp_constr (lid, [x; t_arity])} ) + {x with Parsetree.ptyp_desc = Ptyp_constr (lid, [x])} ) | _ -> (type_annotation, fun ~arity:_ x -> x) in let result_type, arg_types_ty = diff --git a/compiler/gentype/TranslateTypeExprFromTypes.ml b/compiler/gentype/TranslateTypeExprFromTypes.ml index 02181693a25..1e537ea8721 100644 --- a/compiler/gentype/TranslateTypeExprFromTypes.ml +++ b/compiler/gentype/TranslateTypeExprFromTypes.ml @@ -231,8 +231,7 @@ let translate_constr ~config ~params_translation ~(path : Path.t) ~type_env = {param_translation with type_ = Promise param_translation.type_} | (["Js"; "Dict"; "t"] | ["Dict"; "t"] | ["dict"]), [param_translation] -> {param_translation with type_ = Dict param_translation.type_} - | ["function$"], [arg; _arity] -> - {dependencies = arg.dependencies; type_ = arg.type_} + | ["function$"], [arg] -> {dependencies = arg.dependencies; type_ = arg.type_} | _ -> default_case () type process_variant = { diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index 60f94866ebd..b20d40ecf80 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -123,7 +123,7 @@ module T = struct let fun_t = {fun_t with ptyp_desc = Ptyp_arrow (lbl, t1, t2, Some arity)} in - {typ0 with ptyp_desc = Ptyp_constr (lid, [fun_t; t_arity])} + {typ0 with ptyp_desc = Ptyp_constr (lid, [fun_t])} | _ -> 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 8ad09b1f40d..57ff7f440dd 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -101,6 +101,17 @@ module T = struct | Ptyp_arrow (lab, t1, t2, _) -> arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) + | Ptyp_constr + ( ({txt = Lident "function$"} as lid), + [({ptyp_desc = Ptyp_arrow (_, _, _, Some arity)} as t_arg)] ) -> + let encode_arity_string arity = "Has_arity" ^ string_of_int arity in + let arity_type ~loc arity = + Ast_helper0.Typ.variant ~loc + [Rtag ({txt = encode_arity_string arity; loc}, [], true, [])] + Closed None + in + constr ~loc ~attrs (map_loc sub lid) + [sub.typ sub t_arg; arity_type ~loc:Location.none arity] | Ptyp_constr (lid, tl) -> constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) | Ptyp_object (l, o) -> diff --git a/compiler/ml/ast_uncurried.ml b/compiler/ml/ast_uncurried.ml index 92900e615db..303adcba744 100644 --- a/compiler/ml/ast_uncurried.ml +++ b/compiler/ml/ast_uncurried.ml @@ -1,12 +1,5 @@ (* Uncurried AST *) -let encode_arity_string arity = "Has_arity" ^ string_of_int arity - -let arity_type ~loc arity = - Ast_helper.Typ.variant ~loc - [Rtag ({txt = encode_arity_string arity; loc}, [], true, [])] - Closed None - let uncurried_type ~loc ~arity (t_arg : Parsetree.core_type) = let t_arg = match t_arg.ptyp_desc with @@ -14,8 +7,7 @@ let uncurried_type ~loc ~arity (t_arg : Parsetree.core_type) = {t_arg with ptyp_desc = Ptyp_arrow (l, t1, t2, Some arity)} | _ -> assert false in - let t_arity = arity_type ~loc arity in - Ast_helper.Typ.constr ~loc {txt = Lident "function$"; loc} [t_arg; t_arity] + Ast_helper.Typ.constr ~loc {txt = Lident "function$"; loc} [t_arg] let uncurried_fun ~arity fun_expr = let fun_expr = @@ -38,7 +30,7 @@ let expr_extract_uncurried_fun (expr : Parsetree.expression) = let core_type_is_uncurried_fun (typ : Parsetree.core_type) = match typ.ptyp_desc with - | Ptyp_constr ({txt = Lident "function$"}, [{ptyp_desc = Ptyp_arrow _}; _]) -> + | Ptyp_constr ({txt = Lident "function$"}, [{ptyp_desc = Ptyp_arrow _}]) -> true | _ -> false @@ -46,7 +38,7 @@ let core_type_extract_uncurried_fun (typ : Parsetree.core_type) = match typ.ptyp_desc with | Ptyp_constr ( {txt = Lident "function$"}, - [({ptyp_desc = Ptyp_arrow (_, _, _, Some arity)} as t_arg); _] ) -> + [({ptyp_desc = Ptyp_arrow (_, _, _, Some arity)} as t_arg)] ) -> (arity, t_arg) | _ -> assert false @@ -54,24 +46,11 @@ let type_is_uncurried_fun = Ast_uncurried_utils.type_is_uncurried_fun let type_extract_uncurried_fun (typ : Types.type_expr) = match typ.desc with - | Tconstr (Pident {name = "function$"}, [t_arg; _], _) -> t_arg + | Tconstr (Pident {name = "function$"}, [t_arg], _) -> t_arg | _ -> assert false (* Typed AST *) -let arity_to_type arity = - let arity_s = encode_arity_string arity in - Ctype.newty - (Tvariant - { - row_fields = [(arity_s, Rpresent None)]; - row_more = Ctype.newty Tnil; - row_bound = (); - row_closed = true; - row_fixed = false; - row_name = None; - }) - let tarrow_to_arity (t_arity : Types.type_expr) = match (Ctype.repr t_arity).desc with | Tarrow (_, _, _, _, Some arity) -> arity @@ -86,7 +65,6 @@ let tarrow_to_arity_opt (t_arity : Types.type_expr) = | _ -> None let make_uncurried_type ~env ~arity (t : Types.type_expr) = - let typ_arity = arity_to_type arity in let lid : Longident.t = Lident "function$" in let path = Env.lookup_type lid env in let t = @@ -97,15 +75,14 @@ let make_uncurried_type ~env ~arity (t : Types.type_expr) = | Tvar _ -> t | _ -> assert false in - Ctype.newconstr path [t; typ_arity] + Ctype.newconstr path [t] let uncurried_type_get_arity ~env typ = match (Ctype.expand_head env typ).desc with - | Tconstr (Pident {name = "function$"}, [t; _arity], _) -> tarrow_to_arity t + | Tconstr (Pident {name = "function$"}, [t], _) -> tarrow_to_arity t | _ -> assert false let uncurried_type_get_arity_opt ~env typ = match (Ctype.expand_head env typ).desc with - | Tconstr (Pident {name = "function$"}, [t; _arity], _) -> - Some (tarrow_to_arity t) + | Tconstr (Pident {name = "function$"}, [t], _) -> Some (tarrow_to_arity t) | _ -> None diff --git a/compiler/ml/ast_uncurried_utils.ml b/compiler/ml/ast_uncurried_utils.ml index fd0ea898394..564d4531d6f 100644 --- a/compiler/ml/ast_uncurried_utils.ml +++ b/compiler/ml/ast_uncurried_utils.ml @@ -1,4 +1,4 @@ let type_is_uncurried_fun (typ : Types.type_expr) = match typ.desc with - | Tconstr (Pident {name = "function$"}, [{desc = Tarrow _}; _], _) -> true + | Tconstr (Pident {name = "function$"}, [{desc = Tarrow _}], _) -> true | _ -> false diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index b01853f2d67..88c78b7a137 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -2299,7 +2299,7 @@ and unify3 env t1 t1' t2 t2' = | Tfield _, Tfield _ -> (* special case for GADTs *) unify_fields env t1' t2' - | Tconstr (Pident {name = "function$"}, [t_fun; _], _), Tarrow _ -> + | Tconstr (Pident {name = "function$"}, [t_fun], _), Tarrow _ -> (* subtype: an uncurried function is cast to a curried one *) unify2 env t_fun t2 | _ -> ( diff --git a/compiler/ml/predef.ml b/compiler/ml/predef.ml index d9a5deae720..b64e3e23d15 100644 --- a/compiler/ml/predef.ml +++ b/compiler/ml/predef.ml @@ -319,13 +319,13 @@ let common_initial_env add_type add_extension empty_env = Record_regular ); } and decl_uncurried = - let tvar1, tvar2 = (newgenvar (), newgenvar ()) in + let tvar1 = newgenvar () in { decl_abstr with - type_params = [tvar1; tvar2]; - type_arity = 2; + type_params = [tvar1]; + type_arity = 1; type_kind = Type_variant [cstr ident_ctor_uncurried [tvar1]]; - type_variance = [Variance.covariant; Variance.covariant]; + type_variance = [Variance.covariant]; type_unboxed = Types.unboxed_true_default_false; } and decl_unknown = diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 8147d8b3c38..eafc8ae0ce8 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -3530,7 +3530,7 @@ and type_application ?type_clash_context uncurried env funct (sargs : sargs) : let has_uncurried_type funct = let t = funct.exp_type in match (expand_head env t).desc with - | Tconstr (Pident {name = "function$"}, [t; _t_arity], _) -> + | Tconstr (Pident {name = "function$"}, [t], _) -> let arity = match Ast_uncurried.tarrow_to_arity_opt t with | Some arity -> arity @@ -4333,10 +4333,7 @@ let report_error env ppf = function "This function is a curried function where an uncurried function is \ expected" | Expr_type_clash - ( ( _, - { - desc = Tconstr (Pident {name = "function$"}, [{desc = Tvar _}; _], _); - } ) + ( (_, {desc = Tconstr (Pident {name = "function$"}, [{desc = Tvar _}], _)}) :: (_, {desc = Tarrow _}) :: _, _ ) -> @@ -4349,7 +4346,7 @@ let report_error env ppf = function desc = Tconstr ( Pident {name = "function$"}, - [{desc = Tarrow (_, _, _, _, Some arity_a)}; _], + [{desc = Tarrow (_, _, _, _, Some arity_a)}], _ ); } ) :: ( _, @@ -4357,7 +4354,7 @@ let report_error env ppf = function desc = Tconstr ( Pident {name = "function$"}, - [{desc = Tarrow (_, _, _, _, Some arity_b)}; _], + [{desc = Tarrow (_, _, _, _, Some arity_b)}], _ ); } ) :: _, diff --git a/compiler/syntax/src/res_comments_table.ml b/compiler/syntax/src/res_comments_table.ml index f2c6fa2ef1d..30ae2833489 100644 --- a/compiler/syntax/src/res_comments_table.ml +++ b/compiler/syntax/src/res_comments_table.ml @@ -1865,7 +1865,7 @@ and walk_core_type typ t comments = | Ptyp_variant (row_fields, _, _) -> walk_list (row_fields |> List.map (fun rf -> RowField rf)) t comments | Ptyp_constr - ({txt = Lident "function$"}, [({ptyp_desc = Ptyp_arrow _} as desc); _]) -> + ({txt = Lident "function$"}, [({ptyp_desc = Ptyp_arrow _} as desc)]) -> walk_core_type desc t comments | Ptyp_constr (longident, typexprs) -> let before_longident, _afterLongident = diff --git a/compiler/syntax/src/res_outcome_printer.ml b/compiler/syntax/src/res_outcome_printer.ml index c7cb533942b..80feaf742ba 100644 --- a/compiler/syntax/src/res_outcome_printer.ml +++ b/compiler/syntax/src/res_outcome_printer.ml @@ -156,11 +156,10 @@ let rec print_out_type_doc (out_type : Outcometree.out_type) = [(Otyp_arrow _ as arrow_type)] ) -> (* Compatibility with compiler up to v10.x *) print_out_arrow_type arrow_type - | Otyp_constr (Oide_ident "function$", [(Otyp_arrow _ as arrow_type); _arity]) - -> - (* function$<(int, int) => int, [#2]> -> (. int, int) => int *) + | Otyp_constr (Oide_ident "function$", [(Otyp_arrow _ as arrow_type)]) -> + (* function$<(int, int) => int> -> (int, int) => int *) print_out_arrow_type arrow_type - | Otyp_constr (Oide_ident "function$", [Otyp_var _; _arity]) -> + | Otyp_constr (Oide_ident "function$", [Otyp_var _]) -> (* function$<'a, arity> -> _ => _ *) print_out_type_doc (Otyp_stuff "_ => _") | Otyp_constr (out_ident, []) -> @@ -299,7 +298,7 @@ and print_out_arrow_type typ = | [ ( _, ( Otyp_tuple _ | Otyp_arrow _ - | Otyp_constr (Oide_ident "function$", [Otyp_arrow _; _]) ) ); + | Otyp_constr (Oide_ident "function$", [Otyp_arrow _]) ) ); ] -> true (* single argument should not be wrapped *) diff --git a/tests/syntax_tests/data/parsing/errors/other/expected/labelledParameters.res.txt b/tests/syntax_tests/data/parsing/errors/other/expected/labelledParameters.res.txt index a65faff8463..e054529696e 100644 --- a/tests/syntax_tests/data/parsing/errors/other/expected/labelledParameters.res.txt +++ b/tests/syntax_tests/data/parsing/errors/other/expected/labelledParameters.res.txt @@ -34,4 +34,4 @@ let f [arity:3]x ?(y= 2) z = (x + y) + z let g [arity:3]~x:((x)[@res.namedArgLoc ]) ?y:(((y)[@res.namedArgLoc ])= 2) ~z:((z)[@res.namedArgLoc ]) = (x + y) + z -type nonrec f = (x:int -> y:int -> int (a:2), [ `Has_arity2 ]) function$ \ No newline at end of file +type nonrec f = (x:int -> y:int -> int (a:2)) function$ \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/errors/other/expected/regionMissingComma.res.txt b/tests/syntax_tests/data/parsing/errors/other/expected/regionMissingComma.res.txt index 5dc59cb7603..40a466d4445 100644 --- a/tests/syntax_tests/data/parsing/errors/other/expected/regionMissingComma.res.txt +++ b/tests/syntax_tests/data/parsing/errors/other/expected/regionMissingComma.res.txt @@ -24,8 +24,8 @@ external make : (?style:((ReactDOMRe.Style.t)[@res.namedArgLoc ]) -> - ?image:((bool)[@res.namedArgLoc ]) -> React.element (a:2), - [ `Has_arity2 ]) function$ = "ModalContent" + ?image:((bool)[@res.namedArgLoc ]) -> React.element (a:2)) + function$ = "ModalContent" type nonrec 'extraInfo student = { name: string ; diff --git a/tests/syntax_tests/data/parsing/errors/structure/expected/external.res.txt b/tests/syntax_tests/data/parsing/errors/structure/expected/external.res.txt index 220dfdedfff..aef3cb83a43 100644 --- a/tests/syntax_tests/data/parsing/errors/structure/expected/external.res.txt +++ b/tests/syntax_tests/data/parsing/errors/structure/expected/external.res.txt @@ -9,5 +9,4 @@ An external requires the name of the JS value you're referring to, like "setTimeout". external setTimeout : - ((unit -> unit (a:1), [ `Has_arity1 ]) function$ -> int -> float (a:2), - [ `Has_arity2 ]) function$ \ No newline at end of file + ((unit -> unit (a:1)) function$ -> int -> float (a:2)) function$ \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/errors/typeDef/expected/inlineRecord.res.txt b/tests/syntax_tests/data/parsing/errors/typeDef/expected/inlineRecord.res.txt index 0e4870daf5a..1b559e5e211 100644 --- a/tests/syntax_tests/data/parsing/errors/typeDef/expected/inlineRecord.res.txt +++ b/tests/syntax_tests/data/parsing/errors/typeDef/expected/inlineRecord.res.txt @@ -46,6 +46,6 @@ type nonrec user = let make [arity:1](props : < - handleClick: (Click.t -> unit (a:1), [ `Has_arity1 ]) - function$ ;value: string > ) + handleClick: (Click.t -> unit (a:1)) function$ ;value: + string > ) = render props \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/errors/typeDef/expected/namedParameters.res.txt b/tests/syntax_tests/data/parsing/errors/typeDef/expected/namedParameters.res.txt index 42e30cde3d3..ded012ea925 100644 --- a/tests/syntax_tests/data/parsing/errors/typeDef/expected/namedParameters.res.txt +++ b/tests/syntax_tests/data/parsing/errors/typeDef/expected/namedParameters.res.txt @@ -7,4 +7,4 @@ A labeled parameter starts with a `~`. Did you mean: `~stroke`? -type nonrec draw = (stroke:pencil -> unit (a:1), [ `Has_arity1 ]) function$ \ No newline at end of file +type nonrec draw = (stroke:pencil -> unit (a:1)) function$ \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/errors/typeDef/expected/typeParams.res.txt b/tests/syntax_tests/data/parsing/errors/typeDef/expected/typeParams.res.txt index c67f12b9ca2..6c631c97196 100644 --- a/tests/syntax_tests/data/parsing/errors/typeDef/expected/typeParams.res.txt +++ b/tests/syntax_tests/data/parsing/errors/typeDef/expected/typeParams.res.txt @@ -62,16 +62,16 @@ type nonrec 'a node = { type nonrec ('from, 'for) derivedNode = { mutable value: 'to_ ; - updateF: ('from -> 'to_ (a:1), [ `Has_arity1 ]) function$ } + updateF: ('from -> 'to_ (a:1)) function$ } type nonrec ('from, ') derivedNode = { mutable value: 'to_ ; - updateF: ('from -> 'to_ (a:1), [ `Has_arity1 ]) function$ } + updateF: ('from -> 'to_ (a:1)) function$ } type nonrec ('from, ') derivedNode = { mutable value: 'to_ ; - updateF: ('from -> 'to_ (a:1), [ `Has_arity1 ]) function$ } + updateF: ('from -> 'to_ (a:1)) function$ } type nonrec ('from, 'foo) derivedNode = { mutable value: 'to_ ; - updateF: ('from -> 'to_ (a:1), [ `Has_arity1 ]) function$ } \ No newline at end of file + updateF: ('from -> 'to_ (a:1)) function$ } \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/errors/typexpr/expected/arrow.res.txt b/tests/syntax_tests/data/parsing/errors/typexpr/expected/arrow.res.txt index 996672a667f..e5ccd919a63 100644 --- a/tests/syntax_tests/data/parsing/errors/typexpr/expected/arrow.res.txt +++ b/tests/syntax_tests/data/parsing/errors/typexpr/expected/arrow.res.txt @@ -33,8 +33,7 @@ Did you forget a `:` here? It signals the start of a type -external add_nat : - (nat -> int (a:1), [ `Has_arity1 ]) function$ = "add_nat_bytecode" +external add_nat : (nat -> int (a:1)) function$ = "add_nat_bytecode" module Error2 = struct type nonrec observation = @@ -42,8 +41,8 @@ module Error2 = observed: int ; onStep: (currentValue:((unit)[@res.namedArgLoc ]) -> - [%rescript.typehole ] (a:1), - [ `Has_arity1 ]) function$ + [%rescript.typehole ] (a:1)) + function$ } end module Error3 = diff --git a/tests/syntax_tests/data/parsing/errors/typexpr/expected/bsObjSugar.res.txt b/tests/syntax_tests/data/parsing/errors/typexpr/expected/bsObjSugar.res.txt index 461d3abfa7c..dfe23855db4 100644 --- a/tests/syntax_tests/data/parsing/errors/typexpr/expected/bsObjSugar.res.txt +++ b/tests/syntax_tests/data/parsing/errors/typexpr/expected/bsObjSugar.res.txt @@ -142,9 +142,7 @@ type nonrec state = > type nonrec state = < url: string ;protocols: [%rescript.typehole ] > type nonrec state = - < - send: (string -> [%rescript.typehole ] (a:1), [ `Has_arity1 ]) function$ - [@meth ] > + < send: (string -> [%rescript.typehole ] (a:1)) function$ [@meth ] > type nonrec state = < age: [%rescript.typehole ] ;name: string > type nonrec state = < age: [%rescript.typehole ] [@set ] ;name: string > type nonrec state = < age: [%rescript.typehole ] ;.. > diff --git a/tests/syntax_tests/data/parsing/errors/typexpr/expected/garbage.res.txt b/tests/syntax_tests/data/parsing/errors/typexpr/expected/garbage.res.txt index 48b592b3b07..a4e8c445411 100644 --- a/tests/syntax_tests/data/parsing/errors/typexpr/expected/garbage.res.txt +++ b/tests/syntax_tests/data/parsing/errors/typexpr/expected/garbage.res.txt @@ -9,5 +9,5 @@ I'm not sure what to parse here when looking at "?". external printName : - (name:((unit)[@res.namedArgLoc ]) -> unit (a:1), [ `Has_arity1 ]) function$ - = "printName"[@@module {js|moduleName|js}] \ No newline at end of file + (name:((unit)[@res.namedArgLoc ]) -> unit (a:1)) function$ = "printName" +[@@module {js|moduleName|js}] \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/expressions/expected/UncurriedByDefault.res.txt b/tests/syntax_tests/data/parsing/grammar/expressions/expected/UncurriedByDefault.res.txt index 51381aa33c1..679e19d559e 100644 --- a/tests/syntax_tests/data/parsing/grammar/expressions/expected/UncurriedByDefault.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/expressions/expected/UncurriedByDefault.res.txt @@ -6,65 +6,42 @@ let mixFun [arity:3]a b c [arity:3]d e f [arity:2]g h = 4 let bracesFun [arity:1]x [arity:1]y = x + y let cFun2 [arity:2]x y = 3 let uFun2 [arity:2]x y = 3 -type nonrec cTyp = (string -> int (a:1), [ `Has_arity1 ]) function$ -type nonrec uTyp = (string -> int (a:1), [ `Has_arity1 ]) function$ +type nonrec cTyp = (string -> int (a:1)) function$ +type nonrec uTyp = (string -> int (a:1)) function$ type nonrec mixTyp = (string -> string -> string -> (string -> - string -> - string -> - (string -> string -> int (a:2), [ `Has_arity2 ]) function$ (a:3), - [ `Has_arity3 ]) function$ (a:3), - [ `Has_arity3 ]) function$ + string -> string -> (string -> string -> int (a:2)) function$ (a:3)) + function$ (a:3)) + function$ type nonrec bTyp = - (string -> (string -> int (a:1), [ `Has_arity1 ]) function$ (a:1), - [ `Has_arity1 ]) function$ -type nonrec cTyp2 = - (string -> string -> int (a:2), [ `Has_arity2 ]) function$ -type nonrec uTyp2 = - (string -> string -> int (a:2), [ `Has_arity2 ]) function$ -type nonrec cu = (unit -> int (a:1), [ `Has_arity1 ]) function$ -type nonrec cp = (unit -> int (a:1), [ `Has_arity1 ]) function$ -type nonrec cuu = - (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), - [ `Has_arity1 ]) function$ -type nonrec cpu = - (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), - [ `Has_arity1 ]) function$ -type nonrec cup = - (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), - [ `Has_arity1 ]) function$ -type nonrec cpp = - (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), - [ `Has_arity1 ]) function$ -type nonrec cu2 = (unit -> unit -> unit (a:2), [ `Has_arity2 ]) function$ -type nonrec cp2 = (unit -> unit -> unit (a:2), [ `Has_arity2 ]) function$ -type nonrec uu = (unit -> int (a:1), [ `Has_arity1 ]) function$ -type nonrec up = (unit -> int (a:1), [ `Has_arity1 ]) function$ -type nonrec uuu = - (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), - [ `Has_arity1 ]) function$ -type nonrec upu = - (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), - [ `Has_arity1 ]) function$ -type nonrec uup = - (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), - [ `Has_arity1 ]) function$ -type nonrec upp = - (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), - [ `Has_arity1 ]) function$ -type nonrec uu2 = (unit -> unit -> unit (a:2), [ `Has_arity2 ]) function$ -type nonrec up2 = (unit -> unit -> unit (a:2), [ `Has_arity2 ]) function$ + (string -> (string -> int (a:1)) function$ (a:1)) function$ +type nonrec cTyp2 = (string -> string -> int (a:2)) function$ +type nonrec uTyp2 = (string -> string -> int (a:2)) function$ +type nonrec cu = (unit -> int (a:1)) function$ +type nonrec cp = (unit -> int (a:1)) function$ +type nonrec cuu = (unit -> (unit -> int (a:1)) function$ (a:1)) function$ +type nonrec cpu = (unit -> (unit -> int (a:1)) function$ (a:1)) function$ +type nonrec cup = (unit -> (unit -> int (a:1)) function$ (a:1)) function$ +type nonrec cpp = (unit -> (unit -> int (a:1)) function$ (a:1)) function$ +type nonrec cu2 = (unit -> unit -> unit (a:2)) function$ +type nonrec cp2 = (unit -> unit -> unit (a:2)) function$ +type nonrec uu = (unit -> int (a:1)) function$ +type nonrec up = (unit -> int (a:1)) function$ +type nonrec uuu = (unit -> (unit -> int (a:1)) function$ (a:1)) function$ +type nonrec upu = (unit -> (unit -> int (a:1)) function$ (a:1)) function$ +type nonrec uup = (unit -> (unit -> int (a:1)) function$ (a:1)) function$ +type nonrec upp = (unit -> (unit -> int (a:1)) function$ (a:1)) function$ +type nonrec uu2 = (unit -> unit -> unit (a:2)) function$ +type nonrec up2 = (unit -> unit -> unit (a:2)) function$ type nonrec cnested = - ((string -> unit (a:1), [ `Has_arity1 ]) function$ -> unit (a:1), - [ `Has_arity1 ]) function$ + ((string -> unit (a:1)) function$ -> unit (a:1)) function$ type nonrec unested = - ((string -> unit (a:1), [ `Has_arity1 ]) function$ -> unit (a:1), - [ `Has_arity1 ]) function$ -let (uannpoly : ('a -> string (a:1), [ `Has_arity1 ]) function$) = xx -let (uannint : (int -> string (a:1), [ `Has_arity1 ]) function$) = xx + ((string -> unit (a:1)) function$ -> unit (a:1)) function$ +let (uannpoly : ('a -> string (a:1)) function$) = xx +let (uannint : (int -> string (a:1)) function$) = xx let _ = ((fun [arity:1]x -> 34)[@att ]) let _ = ((fun [arity:1]x -> 34)[@res.async ][@att ]) let _ = preserveAttr ((fun [arity:1]x -> 34)[@att ]) @@ -76,16 +53,15 @@ let t3 (type a) (type b) [arity:2](l : a list) (x : a) = x :: l let t4 (type a) (type b) [arity:2](l : a list) (x : a) = x :: l let t5 (type a) (type b) [arity:2](l : a list) (x : a) = x :: l let t6 (type a) (type b) [arity:2](l : a list) (x : a) = x :: l -type nonrec arrowPath1 = (int -> string (a:1), [ `Has_arity1 ]) function$ -type nonrec arrowPath2 = (I.t -> string (a:1), [ `Has_arity1 ]) function$ -type nonrec arrowPath3 = (int -> string (a:1), [ `Has_arity1 ]) function$ -type nonrec arrowPath4 = (I.t -> string (a:1), [ `Has_arity1 ]) function$ +type nonrec arrowPath1 = (int -> string (a:1)) function$ +type nonrec arrowPath2 = (I.t -> string (a:1)) function$ +type nonrec arrowPath3 = (int -> string (a:1)) function$ +type nonrec arrowPath4 = (I.t -> string (a:1)) function$ type nonrec callback1 = - (ReactEvent.Mouse.t -> unit (a:1), [ `Has_arity1 ]) function$ as 'callback -type nonrec callback2 = - (ReactEvent.Mouse.t -> unit as 'u (a:1), [ `Has_arity1 ]) function$ + (ReactEvent.Mouse.t -> unit (a:1)) function$ as 'callback +type nonrec callback2 = (ReactEvent.Mouse.t -> unit as 'u (a:1)) function$ type nonrec callback3 = - (ReactEvent.Mouse.t -> unit (a:1), [ `Has_arity1 ]) function$ as 'callback + (ReactEvent.Mouse.t -> unit (a:1)) function$ as 'callback let cApp = foo 3 let uApp = foo 3 let cFun [arity:1]x = 3 @@ -95,67 +71,44 @@ let bracesFun [arity:1]x [arity:1]y = x + y let cFun2 [arity:2]x y = 3 let uFun2 [arity:2]x y = 3 let cFun2Dots [arity:2]x y = 3 -type nonrec cTyp = (string -> int (a:1), [ `Has_arity1 ]) function$ -type nonrec uTyp = (string -> int (a:1), [ `Has_arity1 ]) function$ +type nonrec cTyp = (string -> int (a:1)) function$ +type nonrec uTyp = (string -> int (a:1)) function$ type nonrec mixTyp = (string -> (string -> string -> (string -> - string -> - string -> - string -> (string -> int (a:1), [ `Has_arity1 ]) function$ (a:4), - [ `Has_arity4 ]) function$ (a:2), - [ `Has_arity2 ]) function$ (a:1), - [ `Has_arity1 ]) function$ + string -> string -> string -> (string -> int (a:1)) function$ (a:4)) + function$ (a:2)) + function$ (a:1)) + function$ type nonrec bTyp = - (string -> (string -> int (a:1), [ `Has_arity1 ]) function$ (a:1), - [ `Has_arity1 ]) function$ -type nonrec cTyp2 = - (string -> string -> int (a:2), [ `Has_arity2 ]) function$ -type nonrec uTyp2 = - (string -> string -> int (a:2), [ `Has_arity2 ]) function$ -type nonrec cu = (unit -> int (a:1), [ `Has_arity1 ]) function$ -type nonrec cp = (unit -> int (a:1), [ `Has_arity1 ]) function$ -type nonrec cuu = - (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), - [ `Has_arity1 ]) function$ -type nonrec cpu = - (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), - [ `Has_arity1 ]) function$ -type nonrec cup = - (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), - [ `Has_arity1 ]) function$ -type nonrec cpp = - (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), - [ `Has_arity1 ]) function$ -type nonrec cu2 = (unit -> unit -> unit (a:2), [ `Has_arity2 ]) function$ -type nonrec cp2 = (unit -> unit -> unit (a:2), [ `Has_arity2 ]) function$ -type nonrec uu = (unit -> int (a:1), [ `Has_arity1 ]) function$ -type nonrec up = (unit -> int (a:1), [ `Has_arity1 ]) function$ -type nonrec uuu = - (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), - [ `Has_arity1 ]) function$ -type nonrec upu = - (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), - [ `Has_arity1 ]) function$ -type nonrec uup = - (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), - [ `Has_arity1 ]) function$ -type nonrec upp = - (unit -> (unit -> int (a:1), [ `Has_arity1 ]) function$ (a:1), - [ `Has_arity1 ]) function$ -type nonrec uu2 = (unit -> unit -> unit (a:2), [ `Has_arity2 ]) function$ -type nonrec up2 = (unit -> unit -> unit (a:2), [ `Has_arity2 ]) function$ + (string -> (string -> int (a:1)) function$ (a:1)) function$ +type nonrec cTyp2 = (string -> string -> int (a:2)) function$ +type nonrec uTyp2 = (string -> string -> int (a:2)) function$ +type nonrec cu = (unit -> int (a:1)) function$ +type nonrec cp = (unit -> int (a:1)) function$ +type nonrec cuu = (unit -> (unit -> int (a:1)) function$ (a:1)) function$ +type nonrec cpu = (unit -> (unit -> int (a:1)) function$ (a:1)) function$ +type nonrec cup = (unit -> (unit -> int (a:1)) function$ (a:1)) function$ +type nonrec cpp = (unit -> (unit -> int (a:1)) function$ (a:1)) function$ +type nonrec cu2 = (unit -> unit -> unit (a:2)) function$ +type nonrec cp2 = (unit -> unit -> unit (a:2)) function$ +type nonrec uu = (unit -> int (a:1)) function$ +type nonrec up = (unit -> int (a:1)) function$ +type nonrec uuu = (unit -> (unit -> int (a:1)) function$ (a:1)) function$ +type nonrec upu = (unit -> (unit -> int (a:1)) function$ (a:1)) function$ +type nonrec uup = (unit -> (unit -> int (a:1)) function$ (a:1)) function$ +type nonrec upp = (unit -> (unit -> int (a:1)) function$ (a:1)) function$ +type nonrec uu2 = (unit -> unit -> unit (a:2)) function$ +type nonrec up2 = (unit -> unit -> unit (a:2)) function$ type nonrec cnested = - ((string -> unit (a:1), [ `Has_arity1 ]) function$ -> unit (a:1), - [ `Has_arity1 ]) function$ + ((string -> unit (a:1)) function$ -> unit (a:1)) function$ type nonrec unested = - ((string -> unit (a:1), [ `Has_arity1 ]) function$ -> unit (a:1), - [ `Has_arity1 ]) function$ + ((string -> unit (a:1)) function$ -> unit (a:1)) function$ let pipe1 = 3 |.u f -let (uannpoly : ('a -> string (a:1), [ `Has_arity1 ]) function$) = xx -let (uannint : (int -> string (a:1), [ `Has_arity1 ]) function$) = xx +let (uannpoly : ('a -> string (a:1)) function$) = xx +let (uannint : (int -> string (a:1)) function$) = xx let _ = ((fun [arity:1]x -> 34)[@att ]) let _ = ((fun [arity:1]x -> 34)[@res.async ][@att ]) let _ = preserveAttr ((fun [arity:1]x -> 34)[@att ]) @@ -164,13 +117,12 @@ let t0 (type a) (type b) [arity:2](l : a list) (x : a) = x :: l let t1 (type a) (type b) [arity:2](l : a list) (x : a) = x :: l let t2 (type a) (type b) [arity:2](l : a list) (x : a) = x :: l let t3 (type a) (type b) [arity:2](l : a list) (x : a) = x :: l -type nonrec arrowPath1 = (int -> string (a:1), [ `Has_arity1 ]) function$ -type nonrec arrowPath2 = (I.t -> string (a:1), [ `Has_arity1 ]) function$ -type nonrec arrowPath3 = (int -> string (a:1), [ `Has_arity1 ]) function$ -type nonrec arrowPath4 = (I.t -> string (a:1), [ `Has_arity1 ]) function$ +type nonrec arrowPath1 = (int -> string (a:1)) function$ +type nonrec arrowPath2 = (I.t -> string (a:1)) function$ +type nonrec arrowPath3 = (int -> string (a:1)) function$ +type nonrec arrowPath4 = (I.t -> string (a:1)) function$ type nonrec callback1 = - (ReactEvent.Mouse.t -> unit (a:1), [ `Has_arity1 ]) function$ as 'callback -type nonrec callback2 = - (ReactEvent.Mouse.t -> unit as 'u (a:1), [ `Has_arity1 ]) function$ + (ReactEvent.Mouse.t -> unit (a:1)) function$ as 'callback +type nonrec callback2 = (ReactEvent.Mouse.t -> unit as 'u (a:1)) function$ type nonrec callback3 = - (ReactEvent.Mouse.t -> unit (a:1), [ `Has_arity1 ]) function$ as 'callback \ No newline at end of file + (ReactEvent.Mouse.t -> unit (a:1)) function$ as 'callback \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/expressions/expected/arrow.res.txt b/tests/syntax_tests/data/parsing/grammar/expressions/expected/arrow.res.txt index ac823014385..eef29837314 100644 --- a/tests/syntax_tests/data/parsing/grammar/expressions/expected/arrow.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/expressions/expected/arrow.res.txt @@ -83,5 +83,5 @@ let un = (() : u) type nonrec ('a, 'b) d = ('a * 'b) let c [arity:1]() = ((1, 2) : ('a, 'b) d) let fn [arity:1]f = f -type nonrec f = (int -> unit (a:1), [ `Has_arity1 ]) function$ +type nonrec f = (int -> unit (a:1)) function$ let a = fn (fun [arity:1]_ -> () : f) \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/expressions/expected/block.res.txt b/tests/syntax_tests/data/parsing/grammar/expressions/expected/block.res.txt index 723f3f5b212..9035f13ee8f 100644 --- a/tests/syntax_tests/data/parsing/grammar/expressions/expected/block.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/expressions/expected/block.res.txt @@ -53,8 +53,8 @@ let reifyStyle (type a) [arity:1](x : 'a) = let instanceOf = ([%raw (({js|function(x,y) {return +(x instanceof y)}|js}) - [@res.template ])] : ('a -> constructor -> bool (a:2), - [ `Has_arity2 ]) function$) + [@res.template ])] : ('a -> constructor -> bool (a:2)) + function$) end in ((if (Js.typeof x) = {js|string|js} then Obj.magic String diff --git a/tests/syntax_tests/data/parsing/grammar/expressions/expected/locallyAbstractTypes.res.txt b/tests/syntax_tests/data/parsing/grammar/expressions/expected/locallyAbstractTypes.res.txt index 988d3b4fc77..132e76632fc 100644 --- a/tests/syntax_tests/data/parsing/grammar/expressions/expected/locallyAbstractTypes.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/expressions/expected/locallyAbstractTypes.res.txt @@ -14,7 +14,7 @@ let f = ((fun (type t) -> ((fun (type s) -> let cancel_and_collect_callbacks : 'a 'u 'c . (packed_callbacks list -> - ('a, 'u, 'c) promise -> packed_callbacks list (a:2), - [ `Has_arity2 ]) function$ + ('a, 'u, 'c) promise -> packed_callbacks list (a:2)) + function$ = fun (type x) -> fun [arity:2]callbacks_accumulator -> fun (p : (_, _, c) promise) -> () \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/modexpr/expected/functor.res.txt b/tests/syntax_tests/data/parsing/grammar/modexpr/expected/functor.res.txt index 6e1d4b1e661..8e18c0f55bf 100644 --- a/tests/syntax_tests/data/parsing/grammar/modexpr/expected/functor.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/modexpr/expected/functor.res.txt @@ -14,15 +14,13 @@ module F() = Map module F = ((functor () -> Map)[@functorAttr ]) include functor () -> Map include ((functor () -> Map)[@functorAttr ]) -module Make(Cmp:sig - type nonrec t - val eq : (t -> t -> bool (a:2), [ `Has_arity2 ]) function$ +module Make(Cmp:sig type nonrec t val eq : (t -> t -> bool (a:2)) function$ end) : sig type nonrec key = Cmp.t type nonrec coll val empty : coll - val add : (coll -> key -> coll (a:2), [ `Has_arity2 ]) function$ + val add : (coll -> key -> coll (a:2)) function$ end = struct open Cmp diff --git a/tests/syntax_tests/data/parsing/grammar/modtype/expected/parenthesized.res.txt b/tests/syntax_tests/data/parsing/grammar/modtype/expected/parenthesized.res.txt index a69378931a9..051ed166baf 100644 --- a/tests/syntax_tests/data/parsing/grammar/modtype/expected/parenthesized.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/modtype/expected/parenthesized.res.txt @@ -4,13 +4,11 @@ module type Bt = ((Btree)[@attrIdent ][@attrParens ]) module type MyHash = sig include module type of struct include Hashtbl end - val replace : - (('a, 'b) t -> 'a -> 'b -> unit (a:3), [ `Has_arity3 ]) function$ + val replace : (('a, 'b) t -> 'a -> 'b -> unit (a:3)) function$ end module type MyHash = sig include ((module type of struct include Hashtbl end)[@onModTypeOf ][@onParens ]) - val replace : - (('a, 'b) t -> 'a -> 'b -> unit (a:3), [ `Has_arity3 ]) function$ + val replace : (('a, 'b) t -> 'a -> 'b -> unit (a:3)) function$ end \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/modtype/expected/typeof.res.txt b/tests/syntax_tests/data/parsing/grammar/modtype/expected/typeof.res.txt index 5b068bb97a5..616d14735d2 100644 --- a/tests/syntax_tests/data/parsing/grammar/modtype/expected/typeof.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/modtype/expected/typeof.res.txt @@ -1,12 +1,10 @@ module type MyHash = sig include module type of struct include Hashtbl end - val replace : - (('a, 'b) t -> 'a -> 'b -> unit (a:3), [ `Has_arity3 ]) function$ + val replace : (('a, 'b) t -> 'a -> 'b -> unit (a:3)) function$ end module type MyHash = sig include ((module type of struct include Hashtbl end)[@onModuleTypeOf ]) - val replace : - (('a, 'b) t -> 'a -> 'b -> unit (a:3), [ `Has_arity3 ]) function$ + val replace : (('a, 'b) t -> 'a -> 'b -> unit (a:3)) function$ end \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/modtype/expected/with.res.txt b/tests/syntax_tests/data/parsing/grammar/modtype/expected/with.res.txt index 0caa9c3bbfc..e139cf5be9a 100644 --- a/tests/syntax_tests/data/parsing/grammar/modtype/expected/with.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/modtype/expected/with.res.txt @@ -31,13 +31,9 @@ module type A = module type Printable = sig type nonrec t - val print : - (Format.formatter -> t -> unit (a:2), [ `Has_arity2 ]) function$ + val print : (Format.formatter -> t -> unit (a:2)) function$ end module type Comparable = - sig - type nonrec t - val compare : (t -> t -> int (a:2), [ `Has_arity2 ]) function$ - end + sig type nonrec t val compare : (t -> t -> int (a:2)) function$ end module type PrintableComparable = sig include Printable include (Comparable with type t := t) end \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/signature/expected/external.res.txt b/tests/syntax_tests/data/parsing/grammar/signature/expected/external.res.txt index c7dd1f41a68..fdd4cf2d6f9 100644 --- a/tests/syntax_tests/data/parsing/grammar/signature/expected/external.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/signature/expected/external.res.txt @@ -2,13 +2,10 @@ module type Signature = sig type nonrec t external linkProgram : - (t -> program:((webGlProgram)[@res.namedArgLoc ]) -> unit (a:2), - [ `Has_arity2 ]) function$ = "linkProgram"[@@send ] + (t -> program:((webGlProgram)[@res.namedArgLoc ]) -> unit (a:2)) + function$ = "linkProgram"[@@send ] external add_nat : - (nat -> int -> int -> int (a:3), [ `Has_arity3 ]) function$ = - "add_nat_bytecode" - external svg : - (unit -> React.element (a:1), [ `Has_arity1 ]) function$ = "svg" - external svg : - (unit -> React.element (a:1), [ `Has_arity1 ]) function$ = "svg" + (nat -> int -> int -> int (a:3)) function$ = "add_nat_bytecode" + external svg : (unit -> React.element (a:1)) function$ = "svg" + external svg : (unit -> React.element (a:1)) function$ = "svg" end \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/signature/expected/recModule.res.txt b/tests/syntax_tests/data/parsing/grammar/signature/expected/recModule.res.txt index 63a729d24f4..189a6fdf7a8 100644 --- a/tests/syntax_tests/data/parsing/grammar/signature/expected/recModule.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/signature/expected/recModule.res.txt @@ -5,7 +5,7 @@ module type Signature = type nonrec t = | Leaf of string | Node of ASet.t - val compare : (t -> t -> int (a:2), [ `Has_arity2 ]) function$ + val compare : (t -> t -> int (a:2)) function$ end and ASet: (Set.S with type elt = A.t) and BTree: (Btree.S with type elt = A.t) @@ -14,7 +14,7 @@ module type Signature = type nonrec t = | Leaf of string | Node of ASet.t - val compare : (t -> t -> int (a:2), [ `Has_arity2 ]) function$ + val compare : (t -> t -> int (a:2)) function$ end[@@onFirstAttr ] and ASet: (Set.S with type elt = A.t)[@@onSecondAttr ] module rec A: Btree[@@parsableOnNext ] diff --git a/tests/syntax_tests/data/parsing/grammar/structure/expected/externalDefinition.res.txt b/tests/syntax_tests/data/parsing/grammar/structure/expected/externalDefinition.res.txt index aa35574435c..f711d90b412 100644 --- a/tests/syntax_tests/data/parsing/grammar/structure/expected/externalDefinition.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/structure/expected/externalDefinition.res.txt @@ -1,16 +1,12 @@ -external clear : - (t -> int -> unit (a:2), [ `Has_arity2 ]) function$ = "clear" -external add_nat : - (nat -> int (a:1), [ `Has_arity1 ]) function$ = "add_nat_bytecode" +external clear : (t -> int -> unit (a:2)) function$ = "clear" +external add_nat : (nat -> int (a:1)) function$ = "add_nat_bytecode" external attachShader : (t -> program:((webGlProgram)[@res.namedArgLoc ]) -> - shader:((webGlShader)[@res.namedArgLoc ]) -> unit (a:3), - [ `Has_arity3 ]) function$ = "attachShader"[@@send ] -external svg : - (unit -> React.element (a:1), [ `Has_arity1 ]) function$ = "svg" -external svg : - (unit -> React.element (a:1), [ `Has_arity1 ]) function$ = "svg" -external createDate : - (unit -> unit -> date (a:2), [ `Has_arity2 ]) function$ = "Date"[@@new ] + shader:((webGlShader)[@res.namedArgLoc ]) -> unit (a:3)) + function$ = "attachShader"[@@send ] +external svg : (unit -> React.element (a:1)) function$ = "svg" +external svg : (unit -> React.element (a:1)) function$ = "svg" +external createDate : (unit -> unit -> date (a:2)) function$ = "Date" +[@@new ] let foobar = (createDate ()) () \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/typedefinition/expected/constructorDeclaration.res.txt b/tests/syntax_tests/data/parsing/grammar/typedefinition/expected/constructorDeclaration.res.txt index 18d6b493225..7cc204d5cfe 100644 --- a/tests/syntax_tests/data/parsing/grammar/typedefinition/expected/constructorDeclaration.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/typedefinition/expected/constructorDeclaration.res.txt @@ -83,14 +83,11 @@ type nonrec (_, 'value) node = mutable cachedValue: 'value ; parent: (_, 'value) node ; root: (root, 'value) node ; - updateF: ('value -> 'value (a:1), [ `Has_arity1 ]) function$ ; + updateF: ('value -> 'value (a:1)) function$ ; mutable updatedTime: float } -> (derived, 'value) node type nonrec delta = - | Compute of (< blocked_ids: unit > -> unit (a:1), [ `Has_arity1 ]) - function$ + | Compute of (< blocked_ids: unit > -> unit (a:1)) function$ type nonrec queryDelta = - | Compute of (< blocked_ids: unit > -> unit (a:1), [ `Has_arity1 ]) - function$ - | Compute of (< blocked_ids: unit > -> unit (a:1), [ `Has_arity1 ]) - function$ * (< allowed_ids: unit > -> unit (a:1), [ `Has_arity1 ]) - function$ \ No newline at end of file + | Compute of (< blocked_ids: unit > -> unit (a:1)) function$ + | Compute of (< blocked_ids: unit > -> unit (a:1)) function$ * + (< allowed_ids: unit > -> unit (a:1)) function$ \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/typedefinition/expected/privateTypeEquation.res.txt b/tests/syntax_tests/data/parsing/grammar/typedefinition/expected/privateTypeEquation.res.txt index 83fe17db85b..92f00566f2a 100644 --- a/tests/syntax_tests/data/parsing/grammar/typedefinition/expected/privateTypeEquation.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/typedefinition/expected/privateTypeEquation.res.txt @@ -2,14 +2,11 @@ type nonrec t = private 'a type nonrec t = private string type nonrec t = private _ type nonrec t = private int -type nonrec t = private (int -> int (a:1), [ `Has_arity1 ]) function$ -type nonrec t = private (int -> int (a:1), [ `Has_arity1 ]) function$ +type nonrec t = private (int -> int (a:1)) function$ +type nonrec t = private (int -> int (a:1)) function$ +type nonrec t = private (int -> (int -> int (a:1)) function$ (a:1)) function$ type nonrec t = private - (int -> (int -> int (a:1), [ `Has_arity1 ]) function$ (a:1), - [ `Has_arity1 ]) function$ -type nonrec t = private - (int -> x:((string)[@res.namedArgLoc ]) -> float -> unit (a:3), - [ `Has_arity3 ]) function$ + (int -> x:((string)[@res.namedArgLoc ]) -> float -> unit (a:3)) function$ type nonrec t = private string as 'x type nonrec t = private [%ext ] type nonrec t = private [%ext {js|console.log|js}] diff --git a/tests/syntax_tests/data/parsing/grammar/typedefinition/expected/typeInformation.res.txt b/tests/syntax_tests/data/parsing/grammar/typedefinition/expected/typeInformation.res.txt index 2b74ca5c83c..b8021411785 100644 --- a/tests/syntax_tests/data/parsing/grammar/typedefinition/expected/typeInformation.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/typedefinition/expected/typeInformation.res.txt @@ -71,8 +71,7 @@ type nonrec t = { x: int ; y: int } type nonrec callback = - (ReactEvent.Mouse.t -> unit (a:1), [ `Has_arity1 ]) function$ as 'callback + (ReactEvent.Mouse.t -> unit (a:1)) function$ as 'callback +type nonrec callback = (ReactEvent.Mouse.t -> unit as 'u (a:1)) function$ type nonrec callback = - (ReactEvent.Mouse.t -> unit as 'u (a:1), [ `Has_arity1 ]) function$ -type nonrec callback = - (ReactEvent.Mouse.t -> unit (a:1), [ `Has_arity1 ]) function$ as 'callback \ No newline at end of file + (ReactEvent.Mouse.t -> unit (a:1)) function$ as 'callback \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/alias.res.txt b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/alias.res.txt index ea7097b7290..b5d5ea85e68 100644 --- a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/alias.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/alias.res.txt @@ -1,12 +1,10 @@ type nonrec t = string as 's type nonrec t = _ as 'underscore type nonrec t = parenthesizedType as 'parens -type nonrec t = (int -> unit (a:1), [ `Has_arity1 ]) function$ as 'arrow -type nonrec t = (int -> unit as 'unitAlias (a:1), [ `Has_arity1 ]) function$ -type nonrec t = - (int -> float -> unit (a:2), [ `Has_arity2 ]) function$ as 'arrowAlias -type nonrec t = - (int -> float -> unit as 'unitAlias (a:2), [ `Has_arity2 ]) function$ +type nonrec t = (int -> unit (a:1)) function$ as 'arrow +type nonrec t = (int -> unit as 'unitAlias (a:1)) function$ +type nonrec t = (int -> float -> unit (a:2)) function$ as 'arrowAlias +type nonrec t = (int -> float -> unit as 'unitAlias (a:2)) function$ type nonrec t = int as 'myNumber type nonrec t = Mod.Sub.t as 'longidentAlias type nonrec t = (int as 'r, int as 'g, int as 'b) color as 'rgb @@ -18,13 +16,10 @@ type nonrec tup = ((int as 'x) * (int as 'y)) as 'tupleAlias let (t : string as 's) = () let (t : _ as 'underscore) = () let (t : parenthesizedType as 'parens) = () -let (t : (int -> unit (a:1), [ `Has_arity1 ]) function$ as 'arrow) = () -let (t : (int -> unit as 'unitAlias (a:1), [ `Has_arity1 ]) function$) = () -let (t : - (int -> float -> unit (a:2), [ `Has_arity2 ]) function$ as 'arrowAlias) = - () -let (t : - (int -> float -> unit as 'unitAlias (a:2), [ `Has_arity2 ]) function$) = () +let (t : (int -> unit (a:1)) function$ as 'arrow) = () +let (t : (int -> unit as 'unitAlias (a:1)) function$) = () +let (t : (int -> float -> unit (a:2)) function$ as 'arrowAlias) = () +let (t : (int -> float -> unit as 'unitAlias (a:2)) function$) = () let (t : int as 'myNumber) = () let (t : Mod.Sub.t as 'longidentAlias) = () let (t : (int as 'r, int as 'g, int as 'b) color as 'rgb) = () diff --git a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/es6Arrow.res.txt b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/es6Arrow.res.txt index 2d1766822b3..4320d463c72 100644 --- a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/es6Arrow.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/es6Arrow.res.txt @@ -1,81 +1,71 @@ -type nonrec t = (x -> unit (a:1), [ `Has_arity1 ]) function$ -type nonrec t = (x -> unit (a:1), [ `Has_arity1 ]) function$ -type nonrec t = (int -> string -> unit (a:2), [ `Has_arity2 ]) function$ +type nonrec t = (x -> unit (a:1)) function$ +type nonrec t = (x -> unit (a:1)) function$ +type nonrec t = (int -> string -> unit (a:2)) function$ type nonrec t = - (a:((int)[@res.namedArgLoc ]) -> b:((int)[@res.namedArgLoc ]) -> int (a:2), - [ `Has_arity2 ]) function$ + (a:((int)[@res.namedArgLoc ]) -> b:((int)[@res.namedArgLoc ]) -> int (a:2)) + function$ type nonrec t = (?a:((int)[@res.namedArgLoc ]) -> - ?b:((int)[@res.namedArgLoc ]) -> int (a:2), - [ `Has_arity2 ]) function$ + ?b:((int)[@res.namedArgLoc ]) -> int (a:2)) + function$ type nonrec t = - (int -> - (int -> (int -> int (a:1), [ `Has_arity1 ]) function$ (a:1), - [ `Has_arity1 ]) function$ (a:1), - [ `Has_arity1 ]) function$ + (int -> (int -> (int -> int (a:1)) function$ (a:1)) function$ (a:1)) + function$ type nonrec t = (a:((int)[@res.namedArgLoc ]) -> (b:((int)[@res.namedArgLoc ]) -> - (c:((int)[@res.namedArgLoc ]) -> int (a:1), [ `Has_arity1 ]) - function$ (a:1), - [ `Has_arity1 ]) function$ (a:1), - [ `Has_arity1 ]) function$ -let (f : (x -> unit (a:1), [ `Has_arity1 ]) function$) = xf -let (f : (x -> unit (a:1), [ `Has_arity1 ]) function$) = xf -let (f : (int -> string -> unit (a:2), [ `Has_arity2 ]) function$) = xf + (c:((int)[@res.namedArgLoc ]) -> int (a:1)) function$ (a:1)) + function$ (a:1)) + function$ +let (f : (x -> unit (a:1)) function$) = xf +let (f : (x -> unit (a:1)) function$) = xf +let (f : (int -> string -> unit (a:2)) function$) = xf let (t : - (a:((int)[@res.namedArgLoc ]) -> b:((int)[@res.namedArgLoc ]) -> int (a:2), - [ `Has_arity2 ]) function$) + (a:((int)[@res.namedArgLoc ]) -> b:((int)[@res.namedArgLoc ]) -> int (a:2)) + function$) = xf let (t : (?a:((int)[@res.namedArgLoc ]) -> - ?b:((int)[@res.namedArgLoc ]) -> int (a:2), - [ `Has_arity2 ]) function$) + ?b:((int)[@res.namedArgLoc ]) -> int (a:2)) + function$) = xf let (t : - (int -> - (int -> (int -> int (a:1), [ `Has_arity1 ]) function$ (a:1), - [ `Has_arity1 ]) function$ (a:1), - [ `Has_arity1 ]) function$) + (int -> (int -> (int -> int (a:1)) function$ (a:1)) function$ (a:1)) + function$) = xf let (t : (a:((int)[@res.namedArgLoc ]) -> (b:((int)[@res.namedArgLoc ]) -> - (c:((int)[@res.namedArgLoc ]) -> int (a:1), [ `Has_arity1 ]) - function$ (a:1), - [ `Has_arity1 ]) function$ (a:1), - [ `Has_arity1 ]) function$) + (c:((int)[@res.namedArgLoc ]) -> int (a:1)) function$ (a:1)) + function$ (a:1)) + function$) = xf type nonrec t = f:((int)[@res.namedArgLoc ]) -> string type nonrec t = ?f:((int)[@res.namedArgLoc ]) -> string let (f : f:((int)[@res.namedArgLoc ]) -> string) = fx let (f : ?f:((int)[@res.namedArgLoc ]) -> string) = fx -type nonrec t = - (f:((int)[@res.namedArgLoc ]) -> string (a:1), [ `Has_arity1 ]) function$ +type nonrec t = (f:((int)[@res.namedArgLoc ]) -> string (a:1)) function$ type nonrec t = f:((int)[@res.namedArgLoc ]) -> string type nonrec t = - (f:(((int -> string (a:1), [ `Has_arity1 ]) function$)[@res.namedArgLoc ]) - -> float (a:1), - [ `Has_arity1 ]) function$ + (f:(((int -> string (a:1)) function$)[@res.namedArgLoc ]) -> float (a:1)) + function$ type nonrec t = - f:(((int -> string (a:1), [ `Has_arity1 ]) function$)[@res.namedArgLoc ]) - -> float + f:(((int -> string (a:1)) function$)[@res.namedArgLoc ]) -> float type nonrec t = - f:((int)[@res.namedArgLoc ]) -> - (string -> float (a:1), [ `Has_arity1 ]) function$ + f:((int)[@res.namedArgLoc ]) -> (string -> float (a:1)) function$ type nonrec t = - (((a:((int)[@res.namedArgLoc ]) -> - ((b:((int)[@res.namedArgLoc ]) -> ((float)[@attr ]) -> unit)[@attrBeforeLblB + ((a:((int)[@res.namedArgLoc ]) -> + ((b:((int)[@res.namedArgLoc ]) -> ((float)[@attr ]) -> unit)[@attrBeforeLblB ]) (a:3)) - [@attrBeforeLblA ]), [ `Has_arity3 ]) function$ + [@attrBeforeLblA ]) function$ type nonrec t = (((a:((int)[@res.namedArgLoc ]) -> (((b:((int)[@res.namedArgLoc ]) -> - (((float)[@attr ]) -> unit (a:1), [ `Has_arity1 ]) function$ (a:1), - [ `Has_arity1 ]) function$)[@attrBeforeLblB ]) (a:1), - [ `Has_arity1 ]) function$)[@attrBeforeLblA ]) + (((float)[@attr ]) -> unit (a:1)) function$ (a:1)) + function$)[@attrBeforeLblB ]) (a:1)) + function$)[@attrBeforeLblA ]) type nonrec t = ((a:((int)[@res.namedArgLoc ]) -> unit)[@attr ]) type nonrec 'a getInitialPropsFn = (< query: string dict ;req: 'a Js.t Js.Nullable.t > -> - 'a Js.t Js.Promise.t (a:1), - [ `Has_arity1 ]) function$ \ No newline at end of file + 'a Js.t Js.Promise.t (a:1)) + function$ \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/firstClassModules.res.txt b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/firstClassModules.res.txt index 55631f94828..105320cdf36 100644 --- a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/firstClassModules.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/firstClassModules.res.txt @@ -2,8 +2,7 @@ type nonrec t = (module Hashmap) type nonrec t = (module Hashmap with type key = string) type nonrec t = (module Hashmap with type key = string and type value = int) type nonrec toValueLikeInstance = - ('a t -> (module RxValueLikeInstance.S with type a = 'a) (a:1), - [ `Has_arity1 ]) function$ + ('a t -> (module RxValueLikeInstance.S with type a = 'a) (a:1)) function$ type nonrec 'a t = (module Test with type a = 'a) type nonrec t = (module Console) ref let (devices : (string, (module DEVICE)) Hastbl.t) = Hashtbl.creat 17 \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/objectTypeSpreading.res.txt b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/objectTypeSpreading.res.txt index 822be0d9b04..eb2c9f1c7ab 100644 --- a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/objectTypeSpreading.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/objectTypeSpreading.res.txt @@ -3,12 +3,10 @@ type nonrec u = < a ;u: int > type nonrec v = < v: int ;a > type nonrec w = < j: int ;a ;k: int ;v > type nonrec t = < a ;u: int > as 'a -type nonrec t = (< a ;u: int > -> unit (a:1), [ `Has_arity1 ]) function$ +type nonrec t = (< a ;u: int > -> unit (a:1)) function$ +type nonrec t = ((< a ;u: int > as 'a) -> unit (a:1)) function$ type nonrec t = - ((< a ;u: int > as 'a) -> unit (a:1), [ `Has_arity1 ]) function$ -type nonrec t = - (< a ;u: int > -> < a ;v: int > -> unit (a:2), [ `Has_arity2 ]) - function$ + (< a ;u: int > -> < a ;v: int > -> unit (a:2)) function$ type nonrec user = < name: string > let (steve : < user ;age: int > ) = [%obj { name = {js|Steve|js}; age = 30 }] diff --git a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/parenthesized.res.txt b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/parenthesized.res.txt index 29e94bf43eb..566d9ac5484 100644 --- a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/parenthesized.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/parenthesized.res.txt @@ -1,3 +1,2 @@ type nonrec t = - (((a:((int)[@res.namedArgLoc ]) -> unit (a:1), [ `Has_arity1 ]) function$) - [@attr ]) \ No newline at end of file + (((a:((int)[@res.namedArgLoc ]) -> unit (a:1)) function$)[@attr ]) \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/poly.res.txt b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/poly.res.txt index 242afda0d69..65b49722d1e 100644 --- a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/poly.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/poly.res.txt @@ -1,20 +1,12 @@ external getLogger : (unit -> < - log: ('a -> unit (a:1), [ `Has_arity1 ]) function$ ;log2: 'a . - (int -> - int (a:1), - [ - `Has_arity1 - ]) - function$ - ;log3: - 'a 'b . + log: ('a -> unit (a:1)) function$ ;log2: 'a . + (int -> int (a:1)) + function$ ;log3: + 'a 'b . ('a -> - 'b -> int (a:2), - [ - `Has_arity2 - ]) + 'b -> int (a:2)) function$ - > (a:1), - [ `Has_arity1 ]) function$ = "./src/logger.mock.js" \ No newline at end of file + > (a:1)) + function$ = "./src/logger.mock.js" \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/polyVariant.res.txt b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/polyVariant.res.txt index 17d57db28a4..de6fd665c0e 100644 --- a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/polyVariant.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/polyVariant.res.txt @@ -3,17 +3,13 @@ module type Conjunctive = sig type nonrec u1 = [ `A | `B ] type nonrec u2 = [ `A | `B | `C ] - val f : - ([< `T of [< u2]&[< u2]&[< u1] ] -> unit (a:1), [ `Has_arity1 ]) - function$ - val g : - ([< `S of [< u2]&[< u2]&[< u1] ] -> unit (a:1), [ `Has_arity1 ]) - function$ + val f : ([< `T of [< u2]&[< u2]&[< u1] ] -> unit (a:1)) function$ + val g : ([< `S of [< u2]&[< u2]&[< u1] ] -> unit (a:1)) function$ val g : ([< `Exotic-S+ of [< `Exotic-u2+ ]&[< `Exotic-u2- ]&[< `Exotic-u1+++ ] ] - -> unit (a:1), - [ `Has_arity1 ]) function$ + -> unit (a:1)) + function$ end type nonrec t = [ s] type nonrec t = [ ListStyleType.t] diff --git a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/uncurried.res.txt b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/uncurried.res.txt index 742dab6a282..5f9275519cb 100644 --- a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/uncurried.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/uncurried.res.txt @@ -1,28 +1,25 @@ type nonrec t = { - mutable field: - (float -> int -> bool -> unit (a:3), [ `Has_arity3 ]) function$ } -type nonrec t = - (float -> int -> bool -> unit (a:3), [ `Has_arity3 ]) function$ + mutable field: (float -> int -> bool -> unit (a:3)) function$ } +type nonrec t = (float -> int -> bool -> unit (a:3)) function$ type nonrec t = (((float)[@attr ]) -> - ((int)[@attr2 ]) -> ((bool)[@attr3 ]) -> ((string)[@attr4 ]) -> unit (a:4), - [ `Has_arity4 ]) function$ + ((int)[@attr2 ]) -> ((bool)[@attr3 ]) -> ((string)[@attr4 ]) -> unit (a:4)) + function$ type nonrec t = (((float -> (((int)[@attr2 ]) -> - (((bool -> - (((string)[@attr4 ]) -> unit (a:1), [ `Has_arity1 ]) function$ (a:1), - [ `Has_arity1 ]) function$)[@attr3 ]) (a:1), - [ `Has_arity1 ]) function$ (a:1), - [ `Has_arity1 ]) function$)[@attr ]) + (((bool -> (((string)[@attr4 ]) -> unit (a:1)) function$ (a:1)) + function$)[@attr3 ]) (a:1)) + function$ (a:1)) + function$)[@attr ]) type nonrec t = (((float)[@attr ]) -> - ((int)[@attr2 ]) -> ((bool)[@attr3 ]) -> ((string)[@attr4 ]) -> unit (a:4), - [ `Has_arity4 ]) function$ + ((int)[@attr2 ]) -> ((bool)[@attr3 ]) -> ((string)[@attr4 ]) -> unit (a:4)) + function$ external setTimeout : - ((unit -> unit (a:1), [ `Has_arity1 ]) function$ -> int -> timerId (a:2), - [ `Has_arity2 ]) function$ = "setTimeout"[@@val ] + ((unit -> unit (a:1)) function$ -> int -> timerId (a:2)) function$ = + "setTimeout"[@@val ] external setTimeout : - ((unit -> unit (a:1), [ `Has_arity1 ]) function$ -> int -> timerId (a:2), - [ `Has_arity2 ]) function$ = "setTimeout" \ No newline at end of file + ((unit -> unit (a:1)) function$ -> int -> timerId (a:2)) function$ = + "setTimeout" \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/unit.res.txt b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/unit.res.txt index 10891245b54..9f8e5effc33 100644 --- a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/unit.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/unit.res.txt @@ -1,11 +1,9 @@ type nonrec t = unit -type nonrec t = (unit -> unit (a:1), [ `Has_arity1 ]) function$ -type nonrec t = (unit -> unit -> unit (a:2), [ `Has_arity2 ]) function$ -type nonrec t = (unit -> unit (a:1), [ `Has_arity1 ]) function$ -let f [arity:1](f : (unit -> unit (a:1), [ `Has_arity1 ]) function$) = f () -let f [arity:1](f : (unit -> unit (a:1), [ `Has_arity1 ]) function$) = f () -let f [arity:1](f : (unit -> unit -> unit (a:2), [ `Has_arity2 ]) function$) - = f () () -external svg : - (unit -> React.element (a:1), [ `Has_arity1 ]) function$ = "svg" -external thing : (unit -> unit (a:1), [ `Has_arity1 ]) function$ = "svg" \ No newline at end of file +type nonrec t = (unit -> unit (a:1)) function$ +type nonrec t = (unit -> unit -> unit (a:2)) function$ +type nonrec t = (unit -> unit (a:1)) function$ +let f [arity:1](f : (unit -> unit (a:1)) function$) = f () +let f [arity:1](f : (unit -> unit (a:1)) function$) = f () +let f [arity:1](f : (unit -> unit -> unit (a:2)) function$) = f () () +external svg : (unit -> React.element (a:1)) function$ = "svg" +external thing : (unit -> unit (a:1)) function$ = "svg" \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/infiniteLoops/expected/nonRecTypes.res.txt b/tests/syntax_tests/data/parsing/infiniteLoops/expected/nonRecTypes.res.txt index 7818d02a437..68389b01460 100644 --- a/tests/syntax_tests/data/parsing/infiniteLoops/expected/nonRecTypes.res.txt +++ b/tests/syntax_tests/data/parsing/infiniteLoops/expected/nonRecTypes.res.txt @@ -88,36 +88,29 @@ include ;;int ;;(t value) = {js||js} ;;{js|BS:6.0.1\x84\x95\xa6\xbe\0\0\0#\0\0\0\r\0\0\0&\0\0\0#\x91\xa0\xa0A\xa0$size@\xa0\xa0A\xa0$root@\xa0\xa0A\xa0'compare@@|js} - external sizeSet : - ('value t -> int -> unit (a:2), [ `Has_arity2 ]) function$ = "size" + external sizeSet : ('value t -> int -> unit (a:2)) function$ = "size" ;;{js|BS:6.0.1\x84\x95\xa6\xbe\0\0\0\x15\0\0\0\t\0\0\0\x1a\0\0\0\x19\xb0\xa0\xa0A\x91@\xa0\xa0A\x04\x03@E\x97\xa0$size@|js} ;;[|(({js|use sizeGet instead or use {abstract = light} explicitly|js}) [@ocaml.deprecated ])|] - external size : - ('value t -> int (a:1), [ `Has_arity1 ]) function$ = "" + external size : ('value t -> int (a:1)) function$ = "" ;;{js|BS:6.0.1\x84\x95\xa6\xbe\0\0\0\x10\0\0\0\x07\0\0\0\x14\0\0\0\x13\xb0\xa0\xa0A\x91@@A\x98\xa0$size@|js} - external sizeGet : - ('value t -> int (a:1), [ `Has_arity1 ]) function$ = "" + external sizeGet : ('value t -> int (a:1)) function$ = "" ;;{js|BS:6.0.1\x84\x95\xa6\xbe\0\0\0\x10\0\0\0\x07\0\0\0\x14\0\0\0\x13\xb0\xa0\xa0A\x91@@A\x98\xa0$size@|js} external rootSet : - ('value t -> 'value node option -> unit (a:2), [ `Has_arity2 ]) - function$ = "root" + ('value t -> 'value node option -> unit (a:2)) function$ = "root" ;;{js|BS:6.0.1\x84\x95\xa6\xbe\0\0\0\x15\0\0\0\t\0\0\0\x1a\0\0\0\x19\xb0\xa0\xa0A\x91@\xa0\xa0A\x04\x03@E\x97\xa0$root@|js} ;;[|(({js|use rootGet instead or use {abstract = light} explicitly|js}) [@ocaml.deprecated ])|] - external root : - ('value t -> 'value node option (a:1), [ `Has_arity1 ]) function$ = - "" + external root : ('value t -> 'value node option (a:1)) function$ = "" ;;{js|BS:6.0.1\x84\x95\xa6\xbe\0\0\0\x10\0\0\0\x07\0\0\0\x14\0\0\0\x13\xb0\xa0\xa0A\x91@@A\x98\xa0$root@|js} external rootGet : - ('value t -> 'value node option (a:1), [ `Has_arity1 ]) function$ = - "" + ('value t -> 'value node option (a:1)) function$ = "" ;;{js|BS:6.0.1\x84\x95\xa6\xbe\0\0\0\x10\0\0\0\x07\0\0\0\x14\0\0\0\x13\xb0\xa0\xa0A\x91@@A\x98\xa0$root@|js} ;;[|(({js|use compareGet instead or use {abstract = light} explicitly|js}) [@ocaml.deprecated ])|] external compare : - ('value t -> [ [%rescript.typehole ]] Js.Internal.fn (a:1), - [ `Has_arity1 ]) function$ + ('value t -> [ [%rescript.typehole ]] Js.Internal.fn (a:1)) + function$ ;;(({js|Arity_2('value, 'value)], int) = "" "BS:6.0.1\x84\x95\xa6\xbe\0\0\0\x13\0\0\0\x07\0\0\0\x14\0\0\0\x13\xb0\xa0\xa0A\x91@@A\x98\xa0'compare@"; diff --git a/tests/syntax_tests/data/parsing/recovery/pattern/expected/constrained.res.txt b/tests/syntax_tests/data/parsing/recovery/pattern/expected/constrained.res.txt index fd51e85add6..3ec1fdf0e8b 100644 --- a/tests/syntax_tests/data/parsing/recovery/pattern/expected/constrained.res.txt +++ b/tests/syntax_tests/data/parsing/recovery/pattern/expected/constrained.res.txt @@ -10,6 +10,4 @@ Did you forget a `)` here? -;;match x with - | (a : (int -> unit (a:1), [ `Has_arity1 ]) function$) -> - [%rescript.exprhole ] \ No newline at end of file +;;match x with | (a : (int -> unit (a:1)) function$) -> [%rescript.exprhole ] \ No newline at end of file diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 61aabc07553..5840282fe6f 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -382,7 +382,7 @@ let valueDetail (typ : Types.type_expr) = let rec collectSignatureTypes (typ_desc : Types.type_desc) = match typ_desc with | Tlink t | Tsubst t | Tpoly (t, []) -> collectSignatureTypes t.desc - | Tconstr (Path.Pident {name = "function$"}, [t; _], _) -> + | Tconstr (Path.Pident {name = "function$"}, [t], _) -> collectSignatureTypes t.desc | Tconstr (path, ts, _) -> ( let p = path_to_string path in From f7f1e5e1a3cc17d99e1e3627fca0b9e6670fe86c Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 18 Dec 2024 11:59:48 +0100 Subject: [PATCH 9/9] Update CHANGELOG.md --- CHANGELOG.md | 1 - 1 file changed, 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 8baa3fdb18f..40affebbd6c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -29,7 +29,6 @@ - AST cleanup: Remove Pexp_function from the AST. https://github.com/rescript-lang/rescript/pull/7198 - Remove unused code from Location and Rescript_cpp modules. https://github.com/rescript-lang/rescript/pull/7150 - Build with OCaml 5.2.1. https://github.com/rescript-lang/rescript-compiler/pull/7201 -- AST cleanup: Remove `Function$` entirely for function definitions. https://github.com/rescript-lang/rescript/pull/7200 # 12.0.0-alpha.5