From be1504884000a723533a8508827003707912e256 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 18 Dec 2024 18:13:22 +0100 Subject: [PATCH] AST: store arity in function type (#7195) * AST: test storing arity in function type * 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. * 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. * Update TestPpx.res.jsout * Remove remaining uses of `type_to_arity`. * Move arity decoding to ast conversion. * Remove the arity parameter of type `function$`. * Update CHANGELOG.md * Update CHANGELOG.md --- CHANGELOG.md | 2 +- analysis/reanalyze/src/DeadOptionalArgs.ml | 8 +- analysis/src/CompletionBackEnd.ml | 4 +- analysis/src/CompletionJsx.ml | 6 +- analysis/src/CreateInterface.ml | 12 +- analysis/src/Shared.ml | 2 +- analysis/src/SignatureHelp.ml | 4 +- analysis/src/TypeUtils.ml | 30 +-- compiler/frontend/ast_comb.ml | 6 +- compiler/frontend/ast_compatible.ml | 11 +- compiler/frontend/ast_compatible.mli | 9 +- compiler/frontend/ast_core_type.ml | 11 +- compiler/frontend/ast_core_type_class_type.ml | 4 +- 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 | 30 +-- compiler/frontend/ast_typ_uncurry.ml | 10 +- compiler/frontend/bs_ast_mapper.ml | 4 +- compiler/gentype/TranslateCoreType.ml | 6 +- .../gentype/TranslateTypeExprFromTypes.ml | 8 +- compiler/ml/ast_helper.ml | 7 +- compiler/ml/ast_helper.mli | 8 +- compiler/ml/ast_iterator.ml | 2 +- compiler/ml/ast_mapper.ml | 4 +- compiler/ml/ast_mapper_from0.ml | 28 ++- compiler/ml/ast_mapper_to0.ml | 13 +- compiler/ml/ast_uncurried.ml | 80 ++++---- compiler/ml/ast_uncurried_utils.ml | 2 +- compiler/ml/asttypes.ml | 2 + compiler/ml/btype.ml | 5 +- compiler/ml/ctype.ml | 33 ++-- compiler/ml/ctype.mli | 3 +- compiler/ml/depend.ml | 2 +- compiler/ml/parsetree.ml | 2 +- compiler/ml/pprintast.ml | 6 +- compiler/ml/predef.ml | 8 +- compiler/ml/printast.ml | 7 +- compiler/ml/printtyp.ml | 15 +- compiler/ml/printtyped.ml | 2 +- compiler/ml/record_type_spread.ml | 4 +- compiler/ml/tast_iterator.ml | 2 +- compiler/ml/tast_mapper.ml | 4 +- compiler/ml/translcore.ml | 2 +- compiler/ml/typecore.ml | 133 +++++++------ compiler/ml/typedecl.ml | 4 +- compiler/ml/typedtree.ml | 7 +- compiler/ml/typedtree.mli | 8 +- compiler/ml/typedtreeIter.ml | 2 +- compiler/ml/typeopt.ml | 2 +- compiler/ml/types.ml | 2 +- compiler/ml/types.mli | 2 +- compiler/ml/typetexp.ml | 6 +- compiler/syntax/src/jsx_v4.ml | 20 +- compiler/syntax/src/res_ast_debugger.ml | 2 +- compiler/syntax/src/res_comments_table.ml | 18 +- compiler/syntax/src/res_core.ml | 12 +- compiler/syntax/src/res_outcome_printer.ml | 9 +- compiler/syntax/src/res_parsetree_viewer.ml | 18 +- .../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 | 8 +- .../typexpr/expected/bsObjSugar.res.txt | 4 +- .../errors/typexpr/expected/garbage.res.txt | 4 +- .../expected/UncurriedByDefault.res.txt | 184 +++++++----------- .../expressions/expected/arrow.res.txt | 2 +- .../expressions/expected/block.res.txt | 4 +- .../expected/locallyAbstractTypes.res.txt | 5 +- .../grammar/modexpr/expected/functor.res.txt | 6 +- .../modtype/expected/parenthesized.res.txt | 4 +- .../grammar/modtype/expected/typeof.res.txt | 4 +- .../grammar/modtype/expected/with.res.txt | 5 +- .../signature/expected/external.res.txt | 11 +- .../signature/expected/recModule.res.txt | 4 +- .../expected/externalDefinition.res.txt | 17 +- .../expected/constructorDeclaration.res.txt | 11 +- .../expected/privateTypeEquation.res.txt | 10 +- .../expected/typeInformation.res.txt | 7 +- .../grammar/typexpr/expected/alias.res.txt | 20 +- .../grammar/typexpr/expected/es6Arrow.res.txt | 86 ++++---- .../expected/firstClassModules.res.txt | 3 +- .../expected/objectTypeSpreading.res.txt | 6 +- .../typexpr/expected/parenthesized.res.txt | 3 +- .../grammar/typexpr/expected/poly.res.txt | 16 +- .../typexpr/expected/polyVariant.res.txt | 10 +- .../typexpr/expected/uncurried.res.txt | 28 +-- .../grammar/typexpr/expected/unit.res.txt | 17 +- .../expected/nonRecTypes.res.txt | 19 +- .../pattern/expected/constrained.res.txt | 3 +- tests/tools_tests/ppx/TestPpx.res | 4 + .../src/expected/TestPpx.res.jsout | 3 + tools/src/tools.ml | 4 +- 97 files changed, 643 insertions(+), 595 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 8baa3fdb18..5bb94ed77f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -30,7 +30,7 @@ - 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 - +- AST cleanup: store arity in function type https://github.com/rescript-lang/rescript/pull/7195 # 12.0.0-alpha.5 diff --git a/analysis/reanalyze/src/DeadOptionalArgs.ml b/analysis/reanalyze/src/DeadOptionalArgs.ml index 8a3c7e4b87..4b825a6f2b 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 b1463ce7d7..bfbcb4c1b0 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 @@ -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 4d68ad3098..271d1203b1 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) = @@ -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 ebb936867f..5f5cdcf6d9 100644 --- a/analysis/src/CreateInterface.ml +++ b/analysis/src/CreateInterface.ml @@ -123,8 +123,9 @@ 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 - | Tarrow (_, {desc = Tconstr (Path.Pident propsId, typeArgs, _)}, retType, _) + | Tconstr (Pident {name = "function$"}, [typ], _) -> getComponentType typ + | 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 18aac6043d..058ede6163 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/SignatureHelp.ml b/analysis/src/SignatureHelp.ml index 8d97c1b096..5d264657c5 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)] ); }; }; } ); @@ -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/analysis/src/TypeUtils.ml b/analysis/src/TypeUtils.ml index 2f3dbe08dd..453083889f 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 @@ -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, _)} @@ -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,8 +242,8 @@ 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 - | Tconstr (Pident {name = "function$"}, [t; _], _) -> + | Tarrow (label, tArg, tRet, _, _) -> loop ~env ((label, tArg) :: acc) tRet + | Tconstr (Pident {name = "function$"}, [t], _) -> extractFunctionType ~env ~package t | Tconstr (path, typeArgs, _) -> ( match References.digConstructor ~env ~package path with @@ -281,9 +281,9 @@ 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; _], _) -> + | 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,14 +910,14 @@ 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, _) -> + | 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 0462a79968..3b1740145e 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 94170e4e40..b4d3595275 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); + 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); + 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 e2b68f601e..185d14c93a 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 7762925487..99cd941609 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 @@ -108,7 +109,7 @@ let make_obj ~loc xs = Typ.object_ ~loc xs Closed *) let rec get_uncurry_arity_aux (ty : t) acc = match ty.ptyp_desc with - | Ptyp_arrow (_, _, new_ty) -> get_uncurry_arity_aux new_ty (succ acc) + | Ptyp_arrow (_, _, new_ty, _) -> get_uncurry_arity_aux new_ty (succ acc) | Ptyp_poly (_, ty) -> get_uncurry_arity_aux ty acc | _ -> acc @@ -119,7 +120,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 +140,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 +148,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 43df6db179..495552182b 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/ast_derive_abstract.ml b/compiler/frontend/ast_derive_abstract.ml index b4bcf122a2..895f721bf2 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 cb2f7385b7..ec40b8e0a7 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 4506f52ca9..a35972018e 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 7fbeb6b30e..df80c9a3d4 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 8dc5f3ff26..7f453335e0 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" @@ -933,15 +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 -> - let t_arity = - match arity with - | Some arity -> Ast_uncurried.arity_type ~loc arity - | None -> arity_ + fun ~arity (x : Parsetree.core_type) -> + 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 = @@ -955,10 +958,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/frontend/ast_typ_uncurry.ml b/compiler/frontend/ast_typ_uncurry.ml index e60738f172..c79daf08ba 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 78adb57b4c..de29fd2791 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/TranslateCoreType.ml b/compiler/gentype/TranslateCoreType.ml index e6ec268ce6..5ade1f08b8 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/gentype/TranslateTypeExprFromTypes.ml b/compiler/gentype/TranslateTypeExprFromTypes.ml index d559a8215a..1e537ea872 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 = { @@ -270,7 +269,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 +279,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 21bb38554f..7160e65b59 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 62ee9276a3..a8969d2d08 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:arity -> + 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 8f64d484c8..bc1c5f8ee9 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 383e9a47bd..83f1f6d761 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 22934888ca..b20d40ecf8 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -99,10 +99,32 @@ 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) -> - 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 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 + {typ0 with ptyp_desc = Ptyp_constr (lid, [fun_t])} + | _ -> 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 30b0834735..57ff7f440d 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -98,9 +98,20 @@ 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 + ( ({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 9305d67d88..303adcba74 100644 --- a/compiler/ml/ast_uncurried.ml +++ b/compiler/ml/ast_uncurried.ml @@ -1,23 +1,13 @@ (* 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 = - let t_arity = arity_type ~loc arity in - Ast_helper.Typ.constr ~loc {txt = Lident "function$"; loc} [t_arg; t_arity] +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 + Ast_helper.Typ.constr ~loc {txt = Lident "function$"; loc} [t_arg] let uncurried_fun ~arity fun_expr = let fun_expr = @@ -40,57 +30,59 @@ 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 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 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 + | Tarrow _ -> assert false + | _ -> + Format.eprintf "t: %a@." Printtyp.raw_type_expr t_arity; + assert false -let type_to_arity (t_arity : Types.type_expr) = +let tarrow_to_arity_opt (t_arity : Types.type_expr) = match (Ctype.repr t_arity).desc with - | Tvariant {row_fields = [(label, _)]} -> decode_arity_string label - | _ -> assert false + | Tarrow (_, _, _, _, arity) -> arity + | _ -> None -let make_uncurried_type ~env ~arity t = - let typ_arity = arity_to_type arity in +let make_uncurried_type ~env ~arity (t : Types.type_expr) = let lid : Longident.t = Lident "function$" in let path = Env.lookup_type lid env in - Ctype.newconstr path [t; typ_arity] + let t = + match t.desc with + | Tarrow (l, t1, t2, c, _) -> + {t with desc = Tarrow (l, t1, t2, c, Some arity)} + | Tconstr _ -> assert false + | Tvar _ -> t + | _ -> assert false + in + Ctype.newconstr path [t] 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], _) -> 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; t_arity], _) -> - Some (type_to_arity t_arity) + | 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 fd0ea89839..564d4531d6 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/asttypes.ml b/compiler/ml/asttypes.ml index 174d3aa793..cd5379cb8e 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/btype.ml b/compiler/ml/btype.ml index 461f1dbf05..7afaf52f4b 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 14ae92491b..88c78b7a13 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; @@ -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 | _ -> ( @@ -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 @@ -2758,16 +2759,16 @@ 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 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, arity)) 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 +2882,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 +3152,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 +3365,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 +3566,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 +3919,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/ctype.mli b/compiler/ml/ctype.mli index b231dc61ac..207b54b6db 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/depend.ml b/compiler/ml/depend.ml index 7d48262a79..8ff2961d68 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 de6c4f0eec..7ee86f3d17 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 f78c40db9b..e13bdb5766 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/predef.ml b/compiler/ml/predef.ml index d9a5deae72..b64e3e23d1 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/printast.ml b/compiler/ml/printast.ml index 385c88f4fe..5ba59bfe67 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/printtyp.ml b/compiler/ml/printtyp.ml index 10716efaf2..ab990159e7 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 @@ -501,7 +506,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 +587,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/printtyped.ml b/compiler/ml/printtyped.ml index 51ec786875..af090ac79c 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/record_type_spread.ml b/compiler/ml/record_type_spread.ml index 73c283b60f..82adebefeb 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/tast_iterator.ml b/compiler/ml/tast_iterator.ml index b925d49336..62167ea372 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 7a60dcf449..bce2002a35 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/translcore.ml b/compiler/ml/translcore.ml index ce51b425e2..47753bc997 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 8af809c5c8..eafc8ae0ce 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))) @@ -730,10 +728,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 +1893,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 +1913,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 +1949,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) @@ -2225,12 +2223,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 @@ -2246,7 +2244,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 | _ -> () @@ -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 @@ -3281,7 +3279,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 +3308,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))) 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 @@ -3517,10 +3517,9 @@ 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))) + (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 = @@ -3528,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], _) -> + 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 = @@ -3552,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 @@ -3564,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 @@ -3574,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 @@ -3582,8 +3588,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 +3602,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 +3626,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 +3662,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 +3702,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 () = @@ -3715,11 +3724,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 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 @@ -3731,14 +3743,12 @@ 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 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 + update_uncurried_arity funct ~nargs:(List.length !ignored + List.length sargs) ret_t in @@ -4323,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 _}) :: _, _ ) -> @@ -4334,13 +4341,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 ( ( _, @@ -4367,10 +4388,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 25af79d146..3cffec6886 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 571dc3f4d6..e909a46b9f 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; @@ -314,7 +313,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 a0d9844574..f75fdfa8f7 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; @@ -420,7 +418,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 858f7da4ca..74213d65a9 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/typeopt.ml b/compiler/ml/typeopt.ml index d4b3a038a2..350269558a 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 5b14935bc3..215f7e72b6 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 9f3ac3397a..ac09932a09 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 cdd561ea6b..bbd02d5498 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 @@ -336,8 +336,8 @@ 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 - ctyp (Ttyp_arrow (l, cty1, cty2)) ty + 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); 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 b1a0b2602e..96b43c61eb 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 5b670076bc..c43c4c7a3f 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 fc8c104944..30ae283348 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 @@ -1863,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_core.ml b/compiler/syntax/src/res_core.ml index 676df152e5..e678dd9092 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/compiler/syntax/src/res_outcome_printer.ml b/compiler/syntax/src/res_outcome_printer.ml index c7cb533942..80feaf742b 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/compiler/syntax/src/res_parsetree_viewer.ml b/compiler/syntax/src/res_parsetree_viewer.ml index 5c55feb51a..1e5aceb1de 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/labelledParameters.res.txt b/tests/syntax_tests/data/parsing/errors/other/expected/labelledParameters.res.txt index 3417147d94..e054529696 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)) 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 256d94b4fc..40a466d444 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, - [ `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 5885a5454a..aef3cb83a4 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, [ `Has_arity1 ]) function$ -> int -> float, - [ `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 24a0fc8dbb..1b559e5e21 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)) 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 8d84646515..ded012ea92 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)) 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 dcf769316a..6c631c9719 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)) function$ } type nonrec ('from, ') derivedNode = { mutable value: 'to_ ; - updateF: ('from -> 'to_, [ `Has_arity1 ]) function$ } + updateF: ('from -> 'to_ (a:1)) function$ } type nonrec ('from, ') derivedNode = { mutable value: 'to_ ; - updateF: ('from -> 'to_, [ `Has_arity1 ]) function$ } + updateF: ('from -> 'to_ (a:1)) 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)) 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 5d79132be9..e5ccd919a6 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,16 +33,16 @@ Did you forget a `:` here? It signals the start of a type -external add_nat : - (nat -> int, [ `Has_arity1 ]) function$ = "add_nat_bytecode" +external add_nat : (nat -> int (a:1)) function$ = "add_nat_bytecode" module Error2 = struct type nonrec observation = { observed: int ; onStep: - (currentValue:((unit)[@res.namedArgLoc ]) -> [%rescript.typehole ], - [ `Has_arity1 ]) function$ + (currentValue:((unit)[@res.namedArgLoc ]) -> + [%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 178e0ee699..dfe23855db 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 ], [ `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 a438e0fa7b..a4e8c44541 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)) 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 35e991f435..679e19d559 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,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, [ `Has_arity1 ]) function$ -type nonrec uTyp = (string -> int, [ `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, [ `Has_arity2 ]) function$, - [ `Has_arity3 ]) function$, - [ `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$ -type nonrec cuu = - (unit -> (unit -> int, [ `Has_arity1 ]) function$, [ `Has_arity1 ]) - function$ -type nonrec cpu = - (unit -> (unit -> int, [ `Has_arity1 ]) function$, [ `Has_arity1 ]) - function$ -type nonrec cup = - (unit -> (unit -> int, [ `Has_arity1 ]) function$, [ `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$ -type nonrec uuu = - (unit -> (unit -> int, [ `Has_arity1 ]) function$, [ `Has_arity1 ]) + string -> string -> (string -> string -> int (a:2)) function$ (a:3)) + function$ (a:3)) function$ -type nonrec upu = - (unit -> (unit -> int, [ `Has_arity1 ]) function$, [ `Has_arity1 ]) - function$ -type nonrec uup = - (unit -> (unit -> int, [ `Has_arity1 ]) function$, [ `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$ +type nonrec bTyp = + (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, [ `Has_arity1 ]) function$ -> unit, [ `Has_arity1 ]) - function$ + ((string -> unit (a:1)) function$ -> unit (a:1)) 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)) 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 ]) @@ -73,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, [ `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)) 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, [ `Has_arity1 ]) function$ as 'callback -type nonrec callback2 = - (ReactEvent.Mouse.t -> unit as 'u, [ `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, [ `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 @@ -92,64 +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, [ `Has_arity1 ]) function$ -type nonrec uTyp = (string -> int, [ `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, [ `Has_arity1 ]) function$, - [ `Has_arity4 ]) function$, - [ `Has_arity2 ]) function$, - [ `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$ -type nonrec cuu = - (unit -> (unit -> int, [ `Has_arity1 ]) function$, [ `Has_arity1 ]) - function$ -type nonrec cpu = - (unit -> (unit -> int, [ `Has_arity1 ]) function$, [ `Has_arity1 ]) - function$ -type nonrec cup = - (unit -> (unit -> int, [ `Has_arity1 ]) function$, [ `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$ -type nonrec uuu = - (unit -> (unit -> int, [ `Has_arity1 ]) function$, [ `Has_arity1 ]) + string -> string -> string -> (string -> int (a:1)) function$ (a:4)) + function$ (a:2)) + function$ (a:1)) function$ -type nonrec upu = - (unit -> (unit -> int, [ `Has_arity1 ]) function$, [ `Has_arity1 ]) - function$ -type nonrec uup = - (unit -> (unit -> int, [ `Has_arity1 ]) function$, [ `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$ +type nonrec bTyp = + (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, [ `Has_arity1 ]) function$ -> unit, [ `Has_arity1 ]) - function$ + ((string -> unit (a:1)) function$ -> unit (a:1)) function$ type nonrec unested = - ((string -> unit, [ `Has_arity1 ]) function$ -> unit, [ `Has_arity1 ]) - function$ + ((string -> unit (a:1)) function$ -> unit (a:1)) 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)) 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 ]) @@ -158,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, [ `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)) 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, [ `Has_arity1 ]) function$ as 'callback -type nonrec callback2 = - (ReactEvent.Mouse.t -> unit as 'u, [ `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, [ `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 ee09e1ad09..eef2983731 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)) 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 83cbea1dee..9035f13ee8 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, - [ `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 162b62c4fa..132e76632f 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, - [ `Has_arity2 ]) function$ + (packed_callbacks list -> + ('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 292fe7c79f..8e18c0f55b 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, [ `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, [ `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 462e4dd07a..051ed166ba 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,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, [ `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, [ `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 27b03d24e2..616d14735d 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,10 @@ 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)) 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)) 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 ad7b6d9b50..e139cf5be9 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,9 @@ 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)) function$ end module type Comparable = - sig type nonrec t val compare : (t -> t -> int, [ `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 5a5e012aa2..fdd4cf2d6f 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,10 @@ module type Signature = sig type nonrec t external linkProgram : - (t -> program:((webGlProgram)[@res.namedArgLoc ]) -> unit, - [ `Has_arity2 ]) function$ = "linkProgram"[@@send ] + (t -> program:((webGlProgram)[@res.namedArgLoc ]) -> unit (a:2)) + function$ = "linkProgram"[@@send ] external add_nat : - (nat -> int -> int -> int, [ `Has_arity3 ]) function$ = - "add_nat_bytecode" - external svg : (unit -> React.element, [ `Has_arity1 ]) function$ = "svg" - external svg : (unit -> React.element, [ `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 831702d0ba..189a6fdf7a 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)) 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)) 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 1ed836fd34..f711d90b41 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,12 @@ -external clear : (t -> int -> unit, [ `Has_arity2 ]) function$ = "clear" -external add_nat : - (nat -> int, [ `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, - [ `Has_arity3 ]) function$ = "attachShader"[@@send ] -external svg : (unit -> React.element, [ `Has_arity1 ]) function$ = "svg" -external svg : (unit -> React.element, [ `Has_arity1 ]) function$ = "svg" -external createDate : - (unit -> unit -> date, [ `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 05bf6b484f..7cc204d5cf 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,11 @@ 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)) 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)) 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)) 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 c4c2a63df9..92f00566f2 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,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, [ `Has_arity1 ]) function$ -type nonrec t = private (int -> int, [ `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, [ `Has_arity1 ]) function$, [ `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)) 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 68fe626531..b802141178 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, [ `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, [ `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)) 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 6633a87691..b5d5ea85e6 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, [ `Has_arity1 ]) function$ as 'arrow -type nonrec t = (int -> unit as 'unitAlias, [ `Has_arity1 ]) function$ -type nonrec t = - (int -> float -> unit, [ `Has_arity2 ]) function$ as 'arrowAlias -type nonrec t = - (int -> float -> unit as 'unitAlias, [ `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,12 +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, [ `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)) 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 3fbf63b11a..4320d463c7 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,77 +1,71 @@ -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)) 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, - [ `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, - [ `Has_arity2 ]) function$ + (?a:((int)[@res.namedArgLoc ]) -> + ?b:((int)[@res.namedArgLoc ]) -> int (a:2)) + function$ type nonrec t = - (int -> - (int -> (int -> int, [ `Has_arity1 ]) function$, [ `Has_arity1 ]) - function$, - [ `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, [ `Has_arity1 ]) function$, - [ `Has_arity1 ]) function$, - [ `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 + (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, - [ `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, - [ `Has_arity2 ]) function$) + (?a:((int)[@res.namedArgLoc ]) -> + ?b:((int)[@res.namedArgLoc ]) -> int (a:2)) + function$) = xf let (t : - (int -> - (int -> (int -> int, [ `Has_arity1 ]) function$, [ `Has_arity1 ]) - function$, - [ `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, [ `Has_arity1 ]) function$, - [ `Has_arity1 ]) function$, - [ `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, [ `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, [ `Has_arity1 ]) function$)[@res.namedArgLoc ]) -> - float, - [ `Has_arity1 ]) function$ + (f:(((int -> string (a:1)) function$)[@res.namedArgLoc ]) -> float (a:1)) + function$ type nonrec t = - f:(((int -> string, [ `Has_arity1 ]) function$)[@res.namedArgLoc ]) -> - float + f:(((int -> string (a:1)) function$)[@res.namedArgLoc ]) -> float type nonrec t = - f:((int)[@res.namedArgLoc ]) -> - (string -> float, [ `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 - ])) - [@attrBeforeLblA ]), [ `Has_arity3 ]) function$ + ((a:((int)[@res.namedArgLoc ]) -> + ((b:((int)[@res.namedArgLoc ]) -> ((float)[@attr ]) -> unit)[@attrBeforeLblB + ]) (a:3)) + [@attrBeforeLblA ]) function$ type nonrec t = (((a:((int)[@res.namedArgLoc ]) -> (((b:((int)[@res.namedArgLoc ]) -> - (((float)[@attr ]) -> unit, [ `Has_arity1 ]) function$, - [ `Has_arity1 ]) function$)[@attrBeforeLblB ]), - [ `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, - [ `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 447d072667..105320cdf3 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), [ `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 fc276bf314..eb2c9f1c7a 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,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, [ `Has_arity1 ]) function$ -type nonrec t = ((< a ;u: int > as 'a) -> unit, [ `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 > -> < a ;v: int > -> unit, [ `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 8c63ded5b0..566d9ac548 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, [ `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 541ac45227..65b49722d1 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,12 @@ 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$ > , - [ `Has_arity1 ]) function$ = "./src/logger.mock.js" \ No newline at end of file + log: ('a -> unit (a:1)) function$ ;log2: 'a . + (int -> int (a:1)) + function$ ;log3: + 'a 'b . + ('a -> + 'b -> int (a:2)) + function$ + > (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 d268ca5a8f..de6fd665c0 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,15 +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, [ `Has_arity1 ]) function$ - val g : - ([< `S of [< u2]&[< u2]&[< u1] ] -> unit, [ `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, - [ `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 bf6ecb648d..5f9275519c 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,25 @@ 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)) function$ } +type nonrec t = (float -> int -> bool -> unit (a:3)) function$ type nonrec t = (((float)[@attr ]) -> - ((int)[@attr2 ]) -> ((bool)[@attr3 ]) -> ((string)[@attr4 ]) -> unit, - [ `Has_arity4 ]) function$ + ((int)[@attr2 ]) -> ((bool)[@attr3 ]) -> ((string)[@attr4 ]) -> unit (a:4)) + function$ type nonrec t = (((float -> (((int)[@attr2 ]) -> - (((bool -> (((string)[@attr4 ]) -> unit, [ `Has_arity1 ]) function$, - [ `Has_arity1 ]) function$)[@attr3 ]), - [ `Has_arity1 ]) function$, - [ `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, - [ `Has_arity4 ]) function$ + ((int)[@attr2 ]) -> ((bool)[@attr3 ]) -> ((string)[@attr4 ]) -> unit (a:4)) + function$ external setTimeout : - ((unit -> unit, [ `Has_arity1 ]) function$ -> int -> timerId, - [ `Has_arity2 ]) function$ = "setTimeout"[@@val ] + ((unit -> unit (a:1)) function$ -> int -> timerId (a:2)) function$ = + "setTimeout"[@@val ] external setTimeout : - ((unit -> unit, [ `Has_arity1 ]) function$ -> int -> timerId, - [ `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 dd25f83078..9f8e5effc3 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,9 @@ 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)) 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 9241e845d3..68389b0146 100644 --- a/tests/syntax_tests/data/parsing/infiniteLoops/expected/nonRecTypes.res.txt +++ b/tests/syntax_tests/data/parsing/infiniteLoops/expected/nonRecTypes.res.txt @@ -88,32 +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, [ `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, [ `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, [ `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, [ `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, [ `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, [ `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, - [ `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 2dc285d204..3ec1fdf0e8 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,5 +10,4 @@ Did you forget a `)` here? -;;match x with - | (a : (int -> unit, [ `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/tests/tools_tests/ppx/TestPpx.res b/tests/tools_tests/ppx/TestPpx.res index 88cd500f37..a3288f33e2 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 653567ba05..8235042c40 100644 --- a/tests/tools_tests/src/expected/TestPpx.res.jsout +++ b/tests/tools_tests/src/expected/TestPpx.res.jsout @@ -39,6 +39,8 @@ async function fpromise(promise, _x) { return await promise; } +let Uncurried = {}; + let a = "A"; let b = "B"; @@ -52,4 +54,5 @@ exports.vv = vv; exports.OptionalFields = OptionalFields; exports.Arity = Arity; exports.fpromise = fpromise; +exports.Uncurried = Uncurried; /* Not a pure module */ diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 0048087e0d..5840282fe6 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 @@ -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 = []}] | _ -> []