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 = []}] | _ -> []