From 6eae5c7113027503d6ebde49b7f00f62c6907cc5 Mon Sep 17 00:00:00 2001
From: Cristiano Calcagno <cristianoc@users.noreply.github.com>
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
"@[<hv 2>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 "@[<v>%a%a@]" context (List.rev cxt) (include_err ~env) err)
+ fprintf ppf "@[<v>%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