From 6eae5c7113027503d6ebde49b7f00f62c6907cc5 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 20 Dec 2024 10:43:05 +0100 Subject: [PATCH] remove explicit uses of `function$` in preparation for removing the type entirely --- CHANGELOG.md | 1 + analysis/src/CompletionBackEnd.ml | 8 +- analysis/src/CompletionJsx.ml | 8 +- analysis/src/CreateInterface.ml | 5 +- analysis/src/SignatureHelp.ml | 26 +--- analysis/src/TypeUtils.ml | 33 ++--- compiler/frontend/ast_core_type.ml | 28 ++-- compiler/frontend/ast_core_type_class_type.ml | 24 ++-- compiler/frontend/ast_derive_abstract.ml | 19 ++- compiler/frontend/ast_derive_js_mapper.ml | 2 +- compiler/frontend/ast_exp_handle_external.ml | 15 +- compiler/frontend/ast_external_process.ml | 19 +-- compiler/gentype/TranslateCoreType.ml | 1 + .../gentype/TranslateTypeExprFromTypes.ml | 4 +- compiler/ml/ast_uncurried.ml | 41 +++--- compiler/ml/ast_uncurried_utils.ml | 4 - compiler/ml/ast_untagged_variants.ml | 3 +- compiler/ml/includemod.ml | 17 +-- compiler/ml/tmp_uncurried.ml | 4 + compiler/ml/transl_recmodule.ml | 4 +- compiler/ml/translcore.ml | 2 +- compiler/ml/typecore.ml | 134 ++++++++---------- compiler/ml/typedecl.ml | 4 +- compiler/syntax/src/jsx_common.ml | 6 - compiler/syntax/src/jsx_v4.ml | 10 +- compiler/syntax/src/res_comments_table.ml | 4 +- compiler/syntax/src/res_parens.ml | 5 +- compiler/syntax/src/res_parsetree_viewer.ml | 6 +- compiler/syntax/src/res_parsetree_viewer.mli | 2 +- compiler/syntax/src/res_printer.ml | 34 ++--- .../tests/src/expected/Completion.res.txt | 10 +- tests/tests/src/gpr_2614_test.res | 3 +- tools/src/tools.ml | 14 +- 33 files changed, 216 insertions(+), 284 deletions(-) delete mode 100644 compiler/ml/ast_uncurried_utils.ml create mode 100644 compiler/ml/tmp_uncurried.ml diff --git a/CHANGELOG.md b/CHANGELOG.md index 5bb94ed77f..0f7a2739b0 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -31,6 +31,7 @@ - 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 +- AST cleanup: remove explicit uses of `function$` in preparation for removing the type entirely. https://github.com/rescript-lang/rescript/pull/7206 # 12.0.0-alpha.5 diff --git a/analysis/src/CompletionBackEnd.ml b/analysis/src/CompletionBackEnd.ml index bfbcb4c1b0..f8d52255c2 100644 --- a/analysis/src/CompletionBackEnd.ml +++ b/analysis/src/CompletionBackEnd.ml @@ -1358,12 +1358,8 @@ let rec completeTypedValue ?(typeArgContext : typeArgContext option) ~rawOpens in (* Find all functions in the module that returns type t *) let rec fnReturnsTypeT t = - match t.Types.desc with - | Tlink t1 - | Tsubst t1 - | Tpoly (t1, []) - | Tconstr (Pident {name = "function$"}, [t1], _) -> - fnReturnsTypeT t1 + match (Ast_uncurried.remove_function_dollar t).desc with + | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> fnReturnsTypeT t1 | Tarrow _ -> ( match TypeUtils.extractFunctionType ~env ~package:full.package t with | ( (Nolabel, {desc = Tconstr (Path.Pident {name = "t"}, _, _)}) :: _, diff --git a/analysis/src/CompletionJsx.ml b/analysis/src/CompletionJsx.ml index 271d1203b1..14a241b81d 100644 --- a/analysis/src/CompletionJsx.ml +++ b/analysis/src/CompletionJsx.ml @@ -234,12 +234,8 @@ let getJsxLabels ~componentPath ~findTypeOfValue ~package = | _ -> [] in let rec getLabels (t : Types.type_expr) = - match t.desc with - | Tlink t1 - | Tsubst t1 - | Tpoly (t1, []) - | Tconstr (Pident {name = "function$"}, [t1], _) -> - getLabels t1 + match (Ast_uncurried.remove_function_dollar t).desc with + | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> getLabels t1 | Tconstr (p, [propsType], _) when Path.name p = "React.component" -> ( let rec getPropsType (t : Types.type_expr) = match t.desc with diff --git a/analysis/src/CreateInterface.ml b/analysis/src/CreateInterface.ml index 5f5cdcf6d9..23af97d4ce 100644 --- a/analysis/src/CreateInterface.ml +++ b/analysis/src/CreateInterface.ml @@ -118,12 +118,11 @@ let printSignature ~extractor ~signature = let buf = Buffer.create 10 in - let rec getComponentType (typ : Types.type_expr) = + let getComponentType (typ : Types.type_expr) = let reactElement = Ctype.newconstr (Pdot (Pident (Ident.create "React"), "element", 0)) [] in - match typ.desc with - | Tconstr (Pident {name = "function$"}, [typ], _) -> getComponentType typ + match (Ast_uncurried.remove_function_dollar typ).desc with | Tarrow (_, {desc = Tconstr (Path.Pident propsId, typeArgs, _)}, retType, _, _) when Ident.name propsId = "props" -> diff --git a/analysis/src/SignatureHelp.ml b/analysis/src/SignatureHelp.ml index 5d264657c5..57aed0fcd9 100644 --- a/analysis/src/SignatureHelp.ml +++ b/analysis/src/SignatureHelp.ml @@ -104,25 +104,13 @@ let findFunctionType ~currentFile ~debug ~path ~pos = (* Extracts all parameters from a parsed function signature *) let extractParameters ~signature ~typeStrForParser ~labelPrefixLen = match signature with - | [ - ( { - Parsetree.psig_desc = - Psig_value {pval_type = {ptyp_desc = Ptyp_arrow _} as expr}; - } - | { - psig_desc = - Psig_value - { - pval_type = - { - ptyp_desc = - Ptyp_constr - ( {txt = Lident "function$"}, - [({ptyp_desc = Ptyp_arrow _} as expr)] ); - }; - }; - } ); - ] -> + | [{Parsetree.psig_desc = Psig_value {pval_type = expr}}] + when match + (Ast_uncurried.core_type_remove_function_dollar expr).ptyp_desc + with + | Ptyp_arrow _ -> true + | _ -> false -> + let expr = Ast_uncurried.core_type_remove_function_dollar expr in let rec extractParams expr params = match expr with | { diff --git a/analysis/src/TypeUtils.ml b/analysis/src/TypeUtils.ml index 453083889f..beca404835 100644 --- a/analysis/src/TypeUtils.ml +++ b/analysis/src/TypeUtils.ml @@ -34,9 +34,8 @@ let findTypeViaLoc ~full ~debug (loc : Location.t) = | Some {locType = Typed (_, typExpr, _)} -> Some typExpr | _ -> None -let rec pathFromTypeExpr (t : Types.type_expr) = - match t.desc with - | Tconstr (Pident {name = "function$"}, [t], _) -> pathFromTypeExpr t +let pathFromTypeExpr (t : Types.type_expr) = + match (Ast_uncurried.remove_function_dollar t).desc with | Tconstr (path, _typeArgs, _) | Tlink {desc = Tconstr (path, _typeArgs, _)} | Tsubst {desc = Tconstr (path, _typeArgs, _)} @@ -238,13 +237,11 @@ let rec extractObjectType ~env ~package (t : Types.type_expr) = | _ -> None) | _ -> None -let rec extractFunctionType ~env ~package typ = +let extractFunctionType ~env ~package typ = let rec loop ~env acc (t : Types.type_expr) = - match t.desc with + match (Ast_uncurried.remove_function_dollar 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], _) -> - extractFunctionType ~env ~package t | Tconstr (path, typeArgs, _) -> ( match References.digConstructor ~env ~package path with | Some @@ -277,14 +274,12 @@ let maybeSetTypeArgCtx ?typeArgContextFromTypeManifest ~typeParams ~typeArgs env typeArgContext (* TODO(env-stuff) Maybe this could be removed entirely if we can guarantee that we don't have to look up functions from in here. *) -let rec extractFunctionType2 ?typeArgContext ~env ~package typ = +let extractFunctionType2 ?typeArgContext ~env ~package typ = let rec loop ?typeArgContext ~env acc (t : Types.type_expr) = - match t.desc with + match (Ast_uncurried.remove_function_dollar t).desc with | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> loop ?typeArgContext ~env acc t1 | Tarrow (label, tArg, tRet, _, _) -> loop ?typeArgContext ~env ((label, tArg) :: acc) tRet - | Tconstr (Pident {name = "function$"}, [t], _) -> - extractFunctionType2 ?typeArgContext ~env ~package t | Tconstr (path, typeArgs, _) -> ( match References.digConstructor ~env ~package path with | Some @@ -317,7 +312,7 @@ let rec extractType ?(printOpeningDebug = true) Printf.printf "[extract_type]--> %s" (debugLogTypeArgContext typeArgContext)); let instantiateType = instantiateType2 in - match t.desc with + match (Ast_uncurried.remove_function_dollar t).desc with | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> extractType ?typeArgContext ~printOpeningDebug:false ~env ~package t1 | Tconstr (Path.Pident {name = "option"}, [payloadTypeExpr], _) -> @@ -334,13 +329,6 @@ let rec extractType ?(printOpeningDebug = true) Some (Tstring env, typeArgContext) | Tconstr (Path.Pident {name = "exn"}, [], _) -> Some (Texn env, typeArgContext) - | Tconstr (Pident {name = "function$"}, [t], _) -> ( - match extractFunctionType2 ?typeArgContext t ~env ~package with - | args, tRet, typeArgContext when args <> [] -> - Some - ( Tfunction {env; args; typ = t; uncurried = true; returnType = tRet}, - typeArgContext ) - | _args, _tRet, _typeArgContext -> None) | Tarrow _ -> ( match extractFunctionType2 ?typeArgContext t ~env ~package with | args, tRet, typeArgContext when args <> [] -> @@ -906,11 +894,8 @@ let rec resolveNestedPatternPath (typ : innerType) ~env ~full ~nested = let getArgs ~env (t : Types.type_expr) ~full = let rec getArgsLoop ~env (t : Types.type_expr) ~full ~currentArgumentPosition = - match t.desc with - | Tlink t1 - | Tsubst t1 - | Tpoly (t1, []) - | Tconstr (Pident {name = "function$"}, [t1], _) -> + match (Ast_uncurried.remove_function_dollar t).desc with + | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> getArgsLoop ~full ~env ~currentArgumentPosition t1 | Tarrow (Labelled l, tArg, tRet, _, _) -> (SharedTypes.Completable.Labelled l, tArg) diff --git a/compiler/frontend/ast_core_type.ml b/compiler/frontend/ast_core_type.ml index 99cd941609..9d3c7e05f2 100644 --- a/compiler/frontend/ast_core_type.ml +++ b/compiler/frontend/ast_core_type.ml @@ -124,10 +124,10 @@ let get_uncurry_arity (ty : t) = | _ -> None let get_curry_arity (ty : t) = - if Ast_uncurried.core_type_is_uncurried_fun ty then - let arity, _ = Ast_uncurried.core_type_extract_uncurried_fun ty in - arity - else get_uncurry_arity_aux ty 0 + match Ast_uncurried.core_type_remove_function_dollar ty with + | {ptyp_desc = Ptyp_arrow (_, _, _, Some arity)} -> arity + | _ -> get_uncurry_arity_aux ty 0 + let is_arity_one ty = get_curry_arity ty = 1 type param_type = { @@ -138,12 +138,20 @@ 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, None); - ptyp_loc = loc; - ptyp_attributes = attr; - }) + let t = + Ext_list.fold_right new_arg_types_ty result + (fun {label; ty; attr; loc} acc -> + { + ptyp_desc = Ptyp_arrow (label, ty, acc, None); + ptyp_loc = loc; + ptyp_attributes = attr; + }) + in + match t.ptyp_desc with + | Ptyp_arrow (l, t1, t2, _arity) -> + let arity = List.length new_arg_types_ty in + {t with ptyp_desc = Ptyp_arrow (l, t1, t2, Some arity)} + | _ -> t let list_of_arrow (ty : t) : t * param_type list = let rec aux (ty : t) acc = diff --git a/compiler/frontend/ast_core_type_class_type.ml b/compiler/frontend/ast_core_type_class_type.ml index 495552182b..3496203b44 100644 --- a/compiler/frontend/ast_core_type_class_type.ml +++ b/compiler/frontend/ast_core_type_class_type.ml @@ -65,28 +65,20 @@ let default_typ_mapper = Bs_ast_mapper.default_mapper.typ *) let typ_mapper (self : Bs_ast_mapper.mapper) (ty : Parsetree.core_type) = - match ty with - | { - ptyp_attributes; - ptyp_desc = - ( 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, _)}] ) ); - (* let it go without regard label names, - it will report error later when the label is not empty - *) - ptyp_loc = loc; - } -> ( - match fst (Ast_attributes.process_attributes_rev ptyp_attributes) with + let loc = ty.ptyp_loc in + match (Ast_uncurried.core_type_remove_function_dollar ty).ptyp_desc with + | Ptyp_arrow (label, args, body, _) + (* let it go without regard label names, + it will report error later when the label is not empty + *) -> ( + match fst (Ast_attributes.process_attributes_rev ty.ptyp_attributes) with | Meth_callback _ -> Ast_typ_uncurry.to_method_callback_type loc self label args body | Method _ -> (* Treat @meth as making the type uncurried, for backwards compatibility *) Ast_typ_uncurry.to_uncurry_type loc self label args body | Nothing -> Bs_ast_mapper.default_mapper.typ self ty) - | {ptyp_desc = Ptyp_object (methods, closed_flag); ptyp_loc = loc} -> + | Ptyp_object (methods, closed_flag) -> let ( +> ) attr (typ : Parsetree.core_type) = {typ with ptyp_attributes = attr :: typ.ptyp_attributes} in diff --git a/compiler/frontend/ast_derive_abstract.ml b/compiler/frontend/ast_derive_abstract.ml index 895f721bf2..10086d1039 100644 --- a/compiler/frontend/ast_derive_abstract.ml +++ b/compiler/frontend/ast_derive_abstract.ml @@ -105,18 +105,25 @@ let handle_tdcl light (tdcl : Parsetree.type_declaration) : let is_optional = Ast_attributes.has_bs_optional pld_attributes in let maker, acc = + let arity = + if List.length labels = List.length label_declarations - 1 then + (* toplevel type *) + Some ((if has_optional_field then 2 else 1) + List.length labels) + else None + in if is_optional then let optional_type = Ast_core_type.lift_option_type pld_type in - ( Ast_compatible.opt_arrow ~loc:pld_loc ~arity:None label_name - pld_type maker, + ( Ast_compatible.opt_arrow ~loc:pld_loc ~arity 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 ~arity:None core_type optional_type) + (Ast_compatible.arrow ~loc ~arity:(Some 1) core_type + optional_type) :: acc ) else - ( Ast_compatible.label_arrow ~loc:pld_loc ~arity:None label_name + ( Ast_compatible.label_arrow ~loc:pld_loc ~arity label_name pld_type maker, Val.mk ~loc:pld_loc (if light then pld_name @@ -127,14 +134,14 @@ 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 ~arity:None core_type pld_type) + (Ast_compatible.arrow ~loc ~arity:(Some 1) 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 ~arity:None core_type + Ast_compatible.arrow ~arity:(Some 2) core_type (Ast_compatible.arrow ~arity:None pld_type (* setter *) (Ast_literal.type_unit ())) in diff --git a/compiler/frontend/ast_derive_js_mapper.ml b/compiler/frontend/ast_derive_js_mapper.ml index ec40b8e0a7..7596e970a5 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 ~arity:None any any)) + (Ast_compatible.arrow ~arity:(Some 1) any any)) let unsafe_index = "_index" diff --git a/compiler/frontend/ast_exp_handle_external.ml b/compiler/frontend/ast_exp_handle_external.ml index df80c9a3d4..27f7afa502 100644 --- a/compiler/frontend/ast_exp_handle_external.ml +++ b/compiler/frontend/ast_exp_handle_external.ml @@ -43,7 +43,8 @@ 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 ~arity:None Nolabel (Typ.any ()) (Typ.any ())) + ~pval_type: + (Typ.arrow ~arity:(Some 1) Nolabel (Typ.any ()) (Typ.any ())) [str_exp]; } in @@ -69,7 +70,8 @@ let handle_debugger loc (payload : Ast_payload.t) = | PStr [] -> Ast_external_mk.local_external_apply loc ~pval_prim:["%debugger"] ~pval_type: - (Typ.arrow ~arity:None Nolabel (Typ.any ()) (Ast_literal.type_unit ())) + (Typ.arrow ~arity:(Some 1) Nolabel (Typ.any ()) + (Ast_literal.type_unit ())) [Ast_literal.val_unit ~loc ()] | _ -> Location.raise_errorf ~loc "%%debugger extension doesn't accept arguments" @@ -93,7 +95,8 @@ 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 ~arity:None Nolabel (Typ.any ()) (Typ.any ())) + ~pval_type: + (Typ.arrow ~arity:(Some 1) Nolabel (Typ.any ()) (Typ.any ())) [exp]; pexp_attributes = (match !is_function with @@ -142,7 +145,8 @@ let handle_ffi ~loc ~payload = exp with pexp_desc = Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_expr"] - ~pval_type:(Typ.arrow ~arity:None Nolabel (Typ.any ()) (Typ.any ())) + ~pval_type: + (Typ.arrow ~arity:(Some 1) Nolabel (Typ.any ()) (Typ.any ())) [exp]; pexp_attributes = (match !is_function with @@ -158,7 +162,8 @@ 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 ~arity:None Nolabel (Typ.any ()) (Typ.any ())) + ~pval_type: + (Typ.arrow ~arity:(Some 1) Nolabel (Typ.any ()) (Typ.any ())) [exp]; } | None -> diff --git a/compiler/frontend/ast_external_process.ml b/compiler/frontend/ast_external_process.ml index 7f453335e0..c5464862fa 100644 --- a/compiler/frontend/ast_external_process.ml +++ b/compiler/frontend/ast_external_process.ml @@ -934,17 +934,11 @@ let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type) Parsetree.core_type * External_ffi_types.t * Parsetree.attributes * bool = 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]) -> + match Ast_uncurried.core_type_remove_function_dollar type_annotation with + | {ptyp_desc = Ptyp_arrow (_, _, _, Some _); _} as t -> ( t, 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])} ) + Ast_uncurried.uncurried_type ~loc ~arity x ) | _ -> (type_annotation, fun ~arity:_ x -> x) in let result_type, arg_types_ty = @@ -961,10 +955,7 @@ let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type) let arity, new_type, spec = process_obj loc external_desc prim_name arg_types_ty result_type in - ( build_uncurried_type ~arity:(Some arity) new_type, - spec, - unused_attrs, - false ) + (build_uncurried_type ~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 = @@ -1036,7 +1027,7 @@ let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type) check_return_wrapper loc external_desc.return_wrapper result_type in let fn_type = Ast_core_type.mk_fn_type new_arg_types_ty result_type in - ( build_uncurried_type ~arity:(Some (List.length new_arg_types_ty)) fn_type, + ( build_uncurried_type ~arity:(List.length new_arg_types_ty) fn_type, External_ffi_types.ffi_bs arg_type_specs return_wrapper ffi, unused_attrs, relative ) diff --git a/compiler/gentype/TranslateCoreType.ml b/compiler/gentype/TranslateCoreType.ml index 5ade1f08b8..efa11ae6f2 100644 --- a/compiler/gentype/TranslateCoreType.ml +++ b/compiler/gentype/TranslateCoreType.ml @@ -114,6 +114,7 @@ let rec translate_arrow_type ~config ~type_vars_gen and translateCoreType_ ~config ~type_vars_gen ?(no_function_return_dependencies = false) ~type_env (core_type : Typedtree.core_type) = + let core_type = Ast_uncurried.tcore_type_remove_function_dollar core_type in match core_type.ctyp_desc with | Ttyp_alias (ct, _) -> ct diff --git a/compiler/gentype/TranslateTypeExprFromTypes.ml b/compiler/gentype/TranslateTypeExprFromTypes.ml index 1e537ea872..5f9eff9c42 100644 --- a/compiler/gentype/TranslateTypeExprFromTypes.ml +++ b/compiler/gentype/TranslateTypeExprFromTypes.ml @@ -231,7 +231,6 @@ 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] -> {dependencies = arg.dependencies; type_ = arg.type_} | _ -> default_case () type process_variant = { @@ -313,7 +312,8 @@ let rec translate_arrow_type ~config ~type_vars_gen ~type_env ~rev_arg_deps {dependencies = all_deps; type_ = function_type} and translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env - (type_expr : Types.type_expr) = + (type_expr_ : Types.type_expr) = + let type_expr = Ast_uncurried.remove_function_dollar type_expr_ in match type_expr.desc with | Tvar None -> let type_name = diff --git a/compiler/ml/ast_uncurried.ml b/compiler/ml/ast_uncurried.ml index 303adcba74..6c12b2731b 100644 --- a/compiler/ml/ast_uncurried.ml +++ b/compiler/ml/ast_uncurried.ml @@ -28,27 +28,6 @@ let expr_extract_uncurried_fun (expr : Parsetree.expression) = | Pexp_fun (_, _, _, _, Some _) -> expr | _ -> assert false -let core_type_is_uncurried_fun (typ : Parsetree.core_type) = - match typ.ptyp_desc with - | 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$"}, - [({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 - | _ -> assert false - (* Typed AST *) let tarrow_to_arity (t_arity : Types.type_expr) = @@ -86,3 +65,23 @@ let uncurried_type_get_arity_opt ~env typ = match (Ctype.expand_head env typ).desc with | Tconstr (Pident {name = "function$"}, [t], _) -> Some (tarrow_to_arity t) | _ -> None + +let remove_function_dollar ?env typ = + match + (match env with + | Some env -> Ctype.expand_head env typ + | None -> Ctype.repr typ) + .desc + with + | Tconstr (Pident {name = "function$"}, [t], _) -> t + | _ -> typ + +let core_type_remove_function_dollar (typ : Parsetree.core_type) = + match typ.ptyp_desc with + | Ptyp_constr ({txt = Lident "function$"}, [t]) -> t + | _ -> typ + +let tcore_type_remove_function_dollar (typ : Typedtree.core_type) = + match typ.ctyp_desc with + | Ttyp_constr (Pident {name = "function$"}, _, [t]) -> t + | _ -> typ diff --git a/compiler/ml/ast_uncurried_utils.ml b/compiler/ml/ast_uncurried_utils.ml deleted file mode 100644 index 564d4531d6..0000000000 --- a/compiler/ml/ast_uncurried_utils.ml +++ /dev/null @@ -1,4 +0,0 @@ -let type_is_uncurried_fun (typ : Types.type_expr) = - match typ.desc with - | Tconstr (Pident {name = "function$"}, [{desc = Tarrow _}], _) -> true - | _ -> false diff --git a/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml index 5a4859b15a..61c58282f3 100644 --- a/compiler/ml/ast_untagged_variants.ml +++ b/compiler/ml/ast_untagged_variants.ml @@ -188,6 +188,7 @@ let type_to_instanceof_backed_obj (t : Types.type_expr) = let get_block_type_from_typ ~env (t : Types.type_expr) : block_type option = let t = !expand_head env t in + let t = Tmp_uncurried.remove_function_dollar t in match t with | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_string -> Some StringType @@ -199,8 +200,6 @@ let get_block_type_from_typ ~env (t : Types.type_expr) : block_type option = Some BigintType | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_bool -> Some BooleanType - | {desc = Tconstr _} as t when Ast_uncurried_utils.type_is_uncurried_fun t -> - Some FunctionType | {desc = Tarrow _} -> Some FunctionType | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_string -> Some StringType diff --git a/compiler/ml/includemod.ml b/compiler/ml/includemod.ml index 7c2686fa93..bc20d929dd 100644 --- a/compiler/ml/includemod.ml +++ b/compiler/ml/includemod.ml @@ -504,23 +504,12 @@ let show_locs ppf (loc1, loc2) = show_loc "Expected declaration" ppf loc2; show_loc "Actual declaration" ppf loc1 -let include_err ~env ppf = function +let include_err ppf = function | Missing_field (id, loc, kind) -> fprintf ppf "The %s `%a' is required but not provided" kind ident id; show_loc "Expected declaration" ppf loc | Value_descriptions (id, d1, d2) -> - let curry_kind_1, curry_kind_2 = - match - (Ctype.expand_head env d1.val_type, Ctype.expand_head env d2.val_type) - with - | {desc = Tarrow _}, {desc = Tconstr (Pident {name = "function$"}, _, _)} - -> - (" (curried)", " (uncurried)") - | {desc = Tconstr (Pident {name = "function$"}, _, _)}, {desc = Tarrow _} - -> - (" (uncurried)", " (curried)") - | _ -> ("", "") - in + let curry_kind_1, curry_kind_2 = ("", "") in fprintf ppf "@[Values do not match:@ %a%s@;<1 -2>is not included in@ %a%s@]" (value_description id) d1 curry_kind_1 (value_description id) d2 @@ -606,7 +595,7 @@ let context ppf cxt = let include_err ppf (cxt, env, err) = Printtyp.wrap_printing_env env (fun () -> - fprintf ppf "@[%a%a@]" context (List.rev cxt) (include_err ~env) err) + fprintf ppf "@[%a%a@]" context (List.rev cxt) include_err err) let buffer = ref Bytes.empty let is_big obj = diff --git a/compiler/ml/tmp_uncurried.ml b/compiler/ml/tmp_uncurried.ml new file mode 100644 index 0000000000..dfa84c9631 --- /dev/null +++ b/compiler/ml/tmp_uncurried.ml @@ -0,0 +1,4 @@ +let remove_function_dollar (typ : Types.type_expr) = + match typ.desc with + | Tconstr (Pident {name = "function$"}, [t], _) -> t + | _ -> typ diff --git a/compiler/ml/transl_recmodule.ml b/compiler/ml/transl_recmodule.ml index 5d3cd38e59..5740047f35 100644 --- a/compiler/ml/transl_recmodule.ml +++ b/compiler/ml/transl_recmodule.ml @@ -50,9 +50,7 @@ let init_shape modl = | [] -> [] | Sig_value (id, {val_kind = Val_reg; val_type = ty}) :: rem -> let is_function t = - Ast_uncurried_utils.type_is_uncurried_fun t - || - match t.desc with + match (Ast_uncurried.remove_function_dollar t).desc with | Tarrow _ -> true | _ -> false in diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 47753bc997..e484d20054 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -700,7 +700,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | Some arity -> let prim = let expanded = Ctype.expand_head e.exp_env e.exp_type in - let extracted = Ast_uncurried.type_extract_uncurried_fun expanded in + let extracted = Ast_uncurried.remove_function_dollar expanded in match (Btype.repr extracted).desc with | Tarrow (Nolabel, t, _, _, _) -> ( match (Ctype.expand_head e.exp_env t).desc with diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index eafc8ae0ce..8ef3fbfa89 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -289,10 +289,9 @@ let extract_concrete_record env ty = | _ -> raise Not_found let extract_concrete_variant env ty = + let ty = Ast_uncurried.remove_function_dollar ty in match extract_concrete_typedecl env ty with - | p0, p, {type_kind = Type_variant cstrs} - when not (Ast_uncurried.type_is_uncurried_fun ty) -> - (p0, p, cstrs) + | p0, p, {type_kind = Type_variant cstrs} -> (p0, p, cstrs) | p0, p, {type_kind = Type_open} -> (p0, p, []) | _ -> raise Not_found @@ -726,7 +725,7 @@ let show_extra_help ppf _env trace = | _ -> () let rec collect_missing_arguments env type1 type2 = - match type1 with + match Ast_uncurried.remove_function_dollar 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, _, _)} when Ctype.matches env typ type2 -> @@ -735,9 +734,6 @@ let rec collect_missing_arguments env type1 type2 = match collect_missing_arguments env typ type2 with | Some res -> Some ((label, argtype) :: res) | None -> None) - | t when Ast_uncurried.type_is_uncurried_fun t -> - let typ = Ast_uncurried.type_extract_uncurried_fun t in - collect_missing_arguments env typ type2 | _ -> None let print_expr_type_clash ?type_clash_context env trace ppf = @@ -2424,17 +2420,16 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp end_def (); wrap_trace_gadt_instances env (lower_args env []) ty; begin_def (); - let uncurried = + let total_app = not @@ Ext_list.exists sexp.pexp_attributes (fun ({txt}, _) -> txt = "res.partial") - && (not @@ is_automatic_curried_application env funct) in let type_clash_context = type_clash_context_from_function sexp sfunct in let args, ty_res, fully_applied = match translate_unified_ops env funct sargs with | Some (targs, result_type) -> (targs, result_type, true) - | None -> type_application ?type_clash_context uncurried env funct sargs + | None -> type_application ?type_clash_context total_app env funct sargs in end_def (); unify_var env (newvar ()) funct.exp_type; @@ -3414,12 +3409,6 @@ and type_argument ?type_clash_context ?recarg env sarg ty_expected' ty_expected unify_exp ?type_clash_context env texp ty_expected; texp -and is_automatic_curried_application env funct = - (* When a curried function is used with uncurried application, treat it as a curried application *) - match (expand_head env funct.exp_type).desc with - | Tarrow _ -> true - | _ -> false - (** This is ad-hoc translation for unifying specific primitive operations See [Unified_ops] module for detailed explanation. *) @@ -3515,7 +3504,7 @@ and translate_unified_ops (env : Env.t) (funct : Typedtree.expression) | _ -> None) | _ -> None -and type_application ?type_clash_context uncurried env funct (sargs : sargs) : +and type_application ?type_clash_context total_app env funct (sargs : sargs) : targs * Types.type_expr * bool = let result_type omitted ty_fun = List.fold_left @@ -3527,34 +3516,38 @@ 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 funct = + let force_tvar = let t = funct.exp_type in match (expand_head env t).desc with - | 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 + | Tvar _ when total_app -> true + | _ -> false + in + let has_uncurried_type funct = + let t = funct.exp_type in + let inner_t = Ast_uncurried.remove_function_dollar ~env t in + if force_tvar then Some (List.length sargs, inner_t) + else + match (Ctype.repr inner_t).desc with + | Tarrow (_, _, _, _, Some arity) -> Some (arity, inner_t) + | _ -> None in let force_uncurried_type funct = - match has_uncurried_type funct with - | None -> ( + if force_tvar then let arity = List.length sargs in let uncurried_typ = Ast_uncurried.make_uncurried_type ~env ~arity (newvar ()) in - match (expand_head env funct.exp_type).desc with - | Tvar _ | Tarrow _ -> unify_exp env funct uncurried_typ - | _ -> - raise - (Error - ( funct.exp_loc, - env, - Apply_non_function (expand_head env funct.exp_type) ))) - | Some _ -> () + unify_exp env funct uncurried_typ + else if + Ast_uncurried.tarrow_to_arity_opt + (Ast_uncurried.remove_function_dollar ~env funct.exp_type) + = None + then + raise + (Error + ( funct.exp_loc, + env, + Apply_non_function (expand_head env funct.exp_type) )) in let extract_uncurried_type funct = let t = funct.exp_type in @@ -3574,7 +3567,7 @@ and type_application ?type_clash_context uncurried env funct (sargs : sargs) : | Some (arity, _) -> let newarity = arity - nargs in let fully_applied = newarity <= 0 in - if uncurried && not fully_applied then + if total_app && not fully_applied then raise (Error ( funct.exp_loc, @@ -3600,7 +3593,7 @@ and type_application ?type_clash_context uncurried env funct (sargs : sargs) : (List.rev args), instance env (result_type omitted ty_fun) ) in - if List.length args < max_arity && uncurried then + if List.length args < max_arity && total_app then match (expand_head env ty_fun).desc with | Tarrow (Optional l, t1, t2, _, _) -> ignored := (Optional l, t1, ty_fun.level) :: !ignored; @@ -3613,7 +3606,7 @@ and type_application ?type_clash_context uncurried env funct (sargs : sargs) : | _ -> collect_args () else collect_args () | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] - when uncurried && omitted = [] && args <> [] + when total_app && 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 ~top_arity:None omitted ty_fun [] @@ -3676,7 +3669,7 @@ and type_application ?type_clash_context uncurried env funct (sargs : sargs) : let sargs, omitted, arg = match extract_label name sargs with | None -> - if optional && (uncurried || label_assoc Nolabel sargs) then ( + if optional && (total_app || label_assoc Nolabel sargs) then ( ignored := (l, ty, lv) :: !ignored; ( sargs, omitted, @@ -3724,9 +3717,9 @@ 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; + if total_app 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 + let top_arity = if total_app then Some max_arity else None in match sargs with (* Special case for ignore: avoid discarding warning *) | [(Nolabel, sarg)] when is_ignore ~env ~arity:top_arity funct -> @@ -4279,7 +4272,18 @@ let type_expr ppf typ = Printtyp.reset_and_mark_loops typ; Printtyp.type_expr ppf typ -let report_error env ppf = function +let report_error env ppf error = + let error = + match error with + | Expr_type_clash ((t1, s1) :: (t2, s2) :: trace, type_clash_context) -> + let s1 = Ast_uncurried.remove_function_dollar s1 in + let s2 = Ast_uncurried.remove_function_dollar s2 in + let t1 = Ast_uncurried.remove_function_dollar t1 in + let t2 = Ast_uncurried.remove_function_dollar t2 in + Expr_type_clash ((t1, s1) :: (t2, s2) :: trace, type_clash_context) + | _ -> error + in + match error with | Polymorphic_label lid -> fprintf ppf "@[The record field %a is polymorphic.@ %s@]" longident lid "You cannot instantiate it in a pattern." @@ -4325,38 +4329,16 @@ let report_error env ppf = function (Ident.name id); spellcheck_idents ppf id valid_idents | Expr_type_clash - ( (_, {desc = Tarrow _}) - :: (_, {desc = Tconstr (Pident {name = "function$"}, _, _)}) + ( (_, {desc = Tarrow (_, _, _, _, None)}) + :: (_, {desc = Tarrow (_, _, _, _, Some _)}) :: _, _ ) -> fprintf ppf "This function is a curried function where an uncurried function is \ expected" | Expr_type_clash - ( (_, {desc = Tconstr (Pident {name = "function$"}, [{desc = Tvar _}], _)}) - :: (_, {desc = Tarrow _}) - :: _, - _ ) -> - fprintf ppf - "This function is an uncurried function where a curried function is \ - expected" - | Expr_type_clash - ( ( _, - { - desc = - Tconstr - ( Pident {name = "function$"}, - [{desc = Tarrow (_, _, _, _, Some arity_a)}], - _ ); - } ) - :: ( _, - { - desc = - Tconstr - ( Pident {name = "function$"}, - [{desc = Tarrow (_, _, _, _, Some arity_b)}], - _ ); - } ) + ( (_, {desc = Tarrow (_, _, _, _, Some arity_a)}) + :: (_, {desc = Tarrow (_, _, _, _, Some arity_b)}) :: _, _ ) when arity_a <> arity_b -> @@ -4476,18 +4458,14 @@ let report_error env ppf = function | Some valid_methods -> spellcheck ppf me valid_methods) | Not_subtype (tr1, tr2) -> report_subtyping_error ppf env tr1 "is not a subtype of" tr2 - | Too_many_arguments (in_function, ty) -> ( + | Too_many_arguments (in_function, ty) -> if (* modified *) in_function then ( fprintf ppf "@[This function expects too many arguments,@ "; fprintf ppf "it should have type@ %a@]" type_expr ty) - else - match ty with - | {desc = Tconstr (Pident {name = "function$"}, _, _)} -> - fprintf ppf "This expression is expected to have an uncurried function" - | _ -> - fprintf ppf "@[This expression should not be a function,@ "; - fprintf ppf "the expected type is@ %a@]" type_expr ty) + else ( + fprintf ppf "@[This expression should not be a function,@ "; + fprintf ppf "the expected type is@ %a@]" type_expr ty) | Abstract_wrong_label (l, ty) -> let label_mark = function | Nolabel -> "but its first argument is not labelled" diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index 3cffec6886..1fa6f403c2 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -1799,8 +1799,8 @@ let parse_arity env core_type ty = match Ast_uncurried.uncurried_type_get_arity_opt ~env ty with | Some arity -> let from_constructor = - match ty.desc with - | Tconstr (_, _, _) -> not (Ast_uncurried_utils.type_is_uncurried_fun ty) + match (Ast_uncurried.remove_function_dollar ty).desc with + | Tconstr (_, _, _) -> true | _ -> false in (arity, from_constructor) diff --git a/compiler/syntax/src/jsx_common.ml b/compiler/syntax/src/jsx_common.ml index 1e749be686..41a7fc685c 100644 --- a/compiler/syntax/src/jsx_common.ml +++ b/compiler/syntax/src/jsx_common.ml @@ -50,12 +50,6 @@ let raise_error_multiple_component ~loc = "Only one component definition is allowed for each module. Move to a \ submodule or other file if necessary." -let extract_uncurried typ = - if Ast_uncurried.core_type_is_uncurried_fun typ then - let _arity, t = Ast_uncurried.core_type_extract_uncurried_fun typ in - t - else typ - let remove_arity binding = let rec remove_arity_record expr = match expr.pexp_desc with diff --git a/compiler/syntax/src/jsx_v4.ml b/compiler/syntax/src/jsx_v4.ml index 96b43c61eb..ad2f7ad5fd 100644 --- a/compiler/syntax/src/jsx_v4.ml +++ b/compiler/syntax/src/jsx_v4.ml @@ -1145,7 +1145,7 @@ let map_binding ~config ~empty_loc ~pstr_loc ~file_name ~rec_flag binding = | _ -> Pat.record (List.rev patterns_with_label) Open in let expression = - Exp.fun_ ~arity:None Nolabel None + Exp.fun_ ~arity:(Some 1) Nolabel None (Pat.constraint_ record_pattern (Typ.constr ~loc:empty_loc {txt = Lident "props"; loc = empty_loc} @@ -1309,7 +1309,9 @@ let transform_structure_item ~config item = check_multiple_components ~config ~loc:pstr_loc; check_string_int_attribute_iter.structure_item check_string_int_attribute_iter item; - let pval_type = Jsx_common.extract_uncurried pval_type in + let pval_type = + Ast_uncurried.core_type_remove_function_dollar pval_type + in let core_type_of_attr = Jsx_common.core_type_of_attrs pval_attributes in let typ_vars_of_core_type = core_type_of_attr @@ -1412,7 +1414,9 @@ let transform_signature_item ~config item = | [] -> [item] | [_] -> check_multiple_components ~config ~loc:psig_loc; - let pval_type = Jsx_common.extract_uncurried pval_type in + let pval_type = + Ast_uncurried.core_type_remove_function_dollar pval_type + in check_string_int_attribute_iter.signature_item check_string_int_attribute_iter item; let core_type_of_attr = Jsx_common.core_type_of_attrs pval_attributes in diff --git a/compiler/syntax/src/res_comments_table.ml b/compiler/syntax/src/res_comments_table.ml index 30ae283348..b7428e53c3 100644 --- a/compiler/syntax/src/res_comments_table.ml +++ b/compiler/syntax/src/res_comments_table.ml @@ -1831,6 +1831,7 @@ and walk_row_field (row_field : Parsetree.row_field) t comments = | Rinherit _ -> () and walk_core_type typ t comments = + let typ = Ast_uncurried.core_type_remove_function_dollar typ in match typ.Parsetree.ptyp_desc with | _ when comments = [] -> () | Ptyp_tuple typexprs -> @@ -1864,9 +1865,6 @@ and walk_core_type typ t comments = attach t.trailing typexpr.ptyp_loc after_typ | 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)]) -> - walk_core_type desc t comments | Ptyp_constr (longident, typexprs) -> let before_longident, _afterLongident = partition_leading_trailing comments longident.loc diff --git a/compiler/syntax/src/res_parens.ml b/compiler/syntax/src/res_parens.ml index 836b98c3f4..c12bc4c959 100644 --- a/compiler/syntax/src/res_parens.ml +++ b/compiler/syntax/src/res_parens.ml @@ -454,9 +454,8 @@ let mod_expr_parens mod_expr = | _ -> false let arrow_return_typ_expr typ_expr = - match typ_expr.Parsetree.ptyp_desc with - | Parsetree.Ptyp_arrow _ -> true - | _ when Ast_uncurried.core_type_is_uncurried_fun typ_expr -> true + match (Ast_uncurried.core_type_remove_function_dollar typ_expr).ptyp_desc with + | Ptyp_arrow _ -> true | _ -> false let pattern_record_row_rhs (pattern : Parsetree.pattern) = diff --git a/compiler/syntax/src/res_parsetree_viewer.ml b/compiler/syntax/src/res_parsetree_viewer.ml index 1e5aceb1de..56d91114de 100644 --- a/compiler/syntax/src/res_parsetree_viewer.ml +++ b/compiler/syntax/src/res_parsetree_viewer.ml @@ -1,6 +1,6 @@ open Parsetree -let arrow_type ?(arity = max_int) ?(attrs = []) ct = +let arrow_type ?(max_arity = max_int) ?(attrs = []) ct = let has_as_attr attrs = Ext_list.exists attrs (fun (x, _) -> x.Asttypes.txt = "as") in @@ -52,8 +52,8 @@ let arrow_type ?(arity = max_int) ?(attrs = []) ct = ptyp_attributes = attrs1; } as typ -> let attrs = attrs @ attrs1 in - process attrs [] {typ with ptyp_attributes = []} arity - | typ -> process attrs [] typ arity + process attrs [] {typ with ptyp_attributes = []} max_arity + | typ -> process attrs [] typ max_arity let functor_type modtype = let rec process acc modtype = diff --git a/compiler/syntax/src/res_parsetree_viewer.mli b/compiler/syntax/src/res_parsetree_viewer.mli index e24e497bd6..56629acd89 100644 --- a/compiler/syntax/src/res_parsetree_viewer.mli +++ b/compiler/syntax/src/res_parsetree_viewer.mli @@ -2,7 +2,7 @@ * The parsetree contains: a => b => c => d, for printing purposes * we restructure the tree into (a, b, c) and its returnType d *) val arrow_type : - ?arity:int -> + ?max_arity:int -> ?attrs:Parsetree.attributes -> Parsetree.core_type -> Parsetree.attributes diff --git a/compiler/syntax/src/res_printer.ml b/compiler/syntax/src/res_printer.ml index 855f6f6d45..6f88b4fc65 100644 --- a/compiler/syntax/src/res_printer.ml +++ b/compiler/syntax/src/res_printer.ml @@ -1588,12 +1588,16 @@ and print_label_declaration ~state (ld : Parsetree.label_declaration) cmt_tbl = and print_typ_expr ~(state : State.t) (typ_expr : Parsetree.core_type) cmt_tbl = let parent_attrs = - let attrs = ParsetreeViewer.filter_parsing_attrs typ_expr.ptyp_attributes in - if Ast_uncurried.core_type_is_uncurried_fun typ_expr then attrs else [] + ParsetreeViewer.filter_parsing_attrs typ_expr.ptyp_attributes in - let print_arrow ?(arity = max_int) typ_expr = + let print_arrow ~arity typ_expr = + let max_arity = + match arity with + | Some arity -> arity + | None -> max_int + in let attrs_before, args, return_type = - ParsetreeViewer.arrow_type ~arity ~attrs:parent_attrs typ_expr + ParsetreeViewer.arrow_type ~max_arity ~attrs:parent_attrs typ_expr in let return_type_needs_parens = match return_type.ptyp_desc with @@ -1616,9 +1620,8 @@ and print_typ_expr ~(state : State.t) (typ_expr : Parsetree.core_type) cmt_tbl = in let typ_doc = let doc = print_typ_expr ~state n cmt_tbl in - match n.ptyp_desc with + match (Ast_uncurried.core_type_remove_function_dollar n).ptyp_desc with | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> add_parens doc - | _ when Ast_uncurried.core_type_is_uncurried_fun n -> add_parens doc | _ -> doc in Doc.group @@ -1663,6 +1666,7 @@ and print_typ_expr ~(state : State.t) (typ_expr : Parsetree.core_type) cmt_tbl = Doc.group (Doc.concat [rendered_args; Doc.text " => "; return_doc]) in let rendered_type = + let typ_expr = Ast_uncurried.core_type_remove_function_dollar typ_expr in match typ_expr.ptyp_desc with | Ptyp_any -> Doc.text "_" | Ptyp_var var -> @@ -1676,9 +1680,10 @@ and print_typ_expr ~(state : State.t) (typ_expr : Parsetree.core_type) cmt_tbl = * Is the "as" part of "unit" or "(string, float) => unit". By printing * parens we guide the user towards its meaning.*) let needs_parens = - match typ.ptyp_desc with + match + (Ast_uncurried.core_type_remove_function_dollar typ).ptyp_desc + with | Ptyp_arrow _ -> true - | _ when Ast_uncurried.core_type_is_uncurried_fun typ -> true | _ -> false in let doc = print_typ_expr ~state typ cmt_tbl in @@ -1691,12 +1696,7 @@ and print_typ_expr ~(state : State.t) (typ_expr : Parsetree.core_type) cmt_tbl = (* object printings *) | Ptyp_object (fields, open_flag) -> print_object ~state ~inline:false fields open_flag cmt_tbl - | Ptyp_arrow _ -> print_arrow typ_expr - | Ptyp_constr _ when Ast_uncurried.core_type_is_uncurried_fun typ_expr -> - let arity, t_arg = - Ast_uncurried.core_type_extract_uncurried_fun typ_expr - in - print_arrow ~arity t_arg + | Ptyp_arrow (_, _, _, arity) -> print_arrow ~arity typ_expr | Ptyp_constr (longident_loc, [{ptyp_desc = Ptyp_object (fields, open_flag)}]) -> (* for foo<{"a": b}>, when the object is long and needs a line break, we @@ -1839,9 +1839,9 @@ and print_typ_expr ~(state : State.t) (typ_expr : Parsetree.core_type) cmt_tbl = ]) in let should_print_its_own_attributes = - match typ_expr.ptyp_desc with - | Ptyp_constr _ when Ast_uncurried.core_type_is_uncurried_fun typ_expr -> - true + match + (Ast_uncurried.core_type_remove_function_dollar typ_expr).ptyp_desc + with | Ptyp_arrow _ (* es6 arrow types print their own attributes *) -> true | _ -> false in diff --git a/tests/analysis_tests/tests/src/expected/Completion.res.txt b/tests/analysis_tests/tests/src/expected/Completion.res.txt index 785f9b00b7..a4855bd813 100644 --- a/tests/analysis_tests/tests/src/expected/Completion.res.txt +++ b/tests/analysis_tests/tests/src/expected/Completion.res.txt @@ -1822,8 +1822,14 @@ Resolved opens 2 Completion Completion ContextPath Value[withCallback](~a) ContextPath Value[withCallback] Path withCallback -Found type for function int -[] +Found type for function (~b: int) => int +[{ + "label": "b", + "kind": 4, + "tags": [], + "detail": "int", + "documentation": null + }] Complete src/Completion.res 332:21 posCursor:[332:21] posNoWhite:[332:20] Found expr:[332:3->332:21] diff --git a/tests/tests/src/gpr_2614_test.res b/tests/tests/src/gpr_2614_test.res index 40d73661cd..9b1c8bddbc 100644 --- a/tests/tests/src/gpr_2614_test.res +++ b/tests/tests/src/gpr_2614_test.res @@ -36,7 +36,8 @@ external a : ?low:int -> hi:int -> a low: a -> int option [@@return undefined_to_opt] lowSet : a -> int -> unit */ -let h0 = a(~hi=2, ~low="x") +let h0 = + a(~hi=2, ~low="x", ...) let h1 = a(~hi=2, ~low="x", ()) diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 5840282fe6..160b0ae19c 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -379,11 +379,9 @@ let path_to_string path = Buffer.contents buf 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], _) -> - collectSignatureTypes t.desc + let rec collectSignatureTypes (typ : Types.type_expr) = + match (Ast_uncurried.remove_function_dollar typ).desc with + | Tlink t | Tsubst t | Tpoly (t, []) -> collectSignatureTypes t | Tconstr (path, ts, _) -> ( let p = path_to_string path in match ts with @@ -392,15 +390,15 @@ let valueDetail (typ : Types.type_expr) = let ts = ts |> List.concat_map (fun (t : Types.type_expr) -> - collectSignatureTypes t.desc) + collectSignatureTypes t) in [{path = p; genericParameters = ts}]) | Tarrow (_, t1, t2, _, _) -> - collectSignatureTypes t1.desc @ collectSignatureTypes t2.desc + collectSignatureTypes t1 @ collectSignatureTypes t2 | Tvar None -> [{path = "_"; genericParameters = []}] | _ -> [] in - match collectSignatureTypes typ.desc with + match collectSignatureTypes typ with | [] -> None | ts -> let parameters, returnType = splitLast ts in