From 09c9c72a2a4c39d8cab87c4a652765ccaef071c5 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Sun, 24 Mar 2024 22:25:48 +0200 Subject: [PATCH 1/2] Fix super error mishandling uncurried function --- .../expected/UncurriedArgsNotApplied.res.expected | 15 +++++++++++++++ .../fixtures/UncurriedArgsNotApplied.res | 3 +++ jscomp/frontend/ast_core_type.ml | 2 +- jscomp/frontend/ast_external_process.ml | 2 +- jscomp/ml/ast_uncurried.ml | 15 ++++++++++++--- jscomp/ml/error_message_utils.ml | 3 ++- jscomp/ml/predef.ml | 1 + jscomp/ml/predef.mli | 1 + jscomp/ml/typecore.ml | 7 ++++++- jscomp/syntax/src/jsx_common.ml | 2 +- jscomp/syntax/src/res_printer.ml | 2 +- 11 files changed, 44 insertions(+), 9 deletions(-) create mode 100644 jscomp/build_tests/super_errors/expected/UncurriedArgsNotApplied.res.expected create mode 100644 jscomp/build_tests/super_errors/fixtures/UncurriedArgsNotApplied.res diff --git a/jscomp/build_tests/super_errors/expected/UncurriedArgsNotApplied.res.expected b/jscomp/build_tests/super_errors/expected/UncurriedArgsNotApplied.res.expected new file mode 100644 index 0000000000..ed86996f2b --- /dev/null +++ b/jscomp/build_tests/super_errors/expected/UncurriedArgsNotApplied.res.expected @@ -0,0 +1,15 @@ + + We've found a bug for you! + /.../fixtures/UncurriedArgsNotApplied.res:3:15-21 + + 1 │ let apply = (fn: (. unit) => option) => fn(. ()) + 2 │ + 3 │ let _ = apply(Some(1)) + 4 │ + + This value might need to be wrapped in a function that takes an extra + parameter of type unit + + Here's the original error message + This has type: option<'a> + But it's expected to have type: (. unit) => option \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/fixtures/UncurriedArgsNotApplied.res b/jscomp/build_tests/super_errors/fixtures/UncurriedArgsNotApplied.res new file mode 100644 index 0000000000..0d8be7204e --- /dev/null +++ b/jscomp/build_tests/super_errors/fixtures/UncurriedArgsNotApplied.res @@ -0,0 +1,3 @@ +let apply = (fn: (. unit) => option) => fn(. ()) + +let _ = apply(Some(1)) diff --git a/jscomp/frontend/ast_core_type.ml b/jscomp/frontend/ast_core_type.ml index 6379c14f30..e7b57b907c 100644 --- a/jscomp/frontend/ast_core_type.ml +++ b/jscomp/frontend/ast_core_type.ml @@ -126,7 +126,7 @@ let get_uncurry_arity (ty : t) = let get_curry_arity (ty : t) = if Ast_uncurried.coreTypeIsUncurriedFun ty then - let arity, _ = Ast_uncurried.typeExtractUncurriedFun ty in + let arity, _ = Ast_uncurried.coreTypeExtractUncurriedFun ty in arity else get_uncurry_arity_aux ty 0 diff --git a/jscomp/frontend/ast_external_process.ml b/jscomp/frontend/ast_external_process.ml index 3cf9ed3116..c00596b252 100644 --- a/jscomp/frontend/ast_external_process.ml +++ b/jscomp/frontend/ast_external_process.ml @@ -69,7 +69,7 @@ let spec_of_ptyp (nolabel : bool) (ptyp : Parsetree.core_type) : | `Uncurry opt_arity -> ( let real_arity = if Ast_uncurried.coreTypeIsUncurriedFun ptyp then - let arity, _ = Ast_uncurried.typeExtractUncurriedFun ptyp in + let arity, _ = Ast_uncurried.coreTypeExtractUncurriedFun ptyp in Some arity else Ast_core_type.get_uncurry_arity ptyp in diff --git a/jscomp/ml/ast_uncurried.ml b/jscomp/ml/ast_uncurried.ml index 1a49b2743a..432bb6cab2 100644 --- a/jscomp/ml/ast_uncurried.ml +++ b/jscomp/ml/ast_uncurried.ml @@ -69,14 +69,20 @@ let coreTypeIsUncurriedFun (typ : Parsetree.core_type) = true | _ -> false -let typeIsUncurriedFun = Ast_uncurried_utils.typeIsUncurriedFun - -let typeExtractUncurriedFun (typ : Parsetree.core_type) = +let coreTypeExtractUncurriedFun (typ : Parsetree.core_type) = match typ.ptyp_desc with | Ptyp_constr ({txt = Lident "function$"}, [tArg; tArity]) -> (arityFromType tArity, tArg) | _ -> assert false +let typeIsUncurriedFun = Ast_uncurried_utils.typeIsUncurriedFun + +let typeExtractUncurriedFun (typ : Types.type_expr) = + match typ.desc with + | Tconstr (Pident {name = "function$"}, [tArg; _], _) -> + tArg + | _ -> assert false + (* Typed AST *) let arity_to_type arity = @@ -114,3 +120,6 @@ let uncurried_type_get_arity_opt ~env typ = | Tconstr (Pident { name = "function$" }, [ _t; tArity ], _) -> Some (type_to_arity tArity) | _ -> None + + + diff --git a/jscomp/ml/error_message_utils.ml b/jscomp/ml/error_message_utils.ml index f0b47ecd59..14a4913c75 100644 --- a/jscomp/ml/error_message_utils.ml +++ b/jscomp/ml/error_message_utils.ml @@ -204,7 +204,8 @@ let typeClashContextMaybeOption ty_expected ty_res = | ( {Types.desc = Tconstr (expectedPath, _, _)}, {Types.desc = Tconstr (typePath, _, _)} ) when Path.same Predef.path_option typePath - && Path.same expectedPath Predef.path_option = false -> + && Path.same expectedPath Predef.path_option = false + && Path.same expectedPath Predef.path_uncurried = false -> Some MaybeUnwrapOption | _ -> None diff --git a/jscomp/ml/predef.ml b/jscomp/ml/predef.ml index a65174625e..ad241cdd23 100644 --- a/jscomp/ml/predef.ml +++ b/jscomp/ml/predef.ml @@ -95,6 +95,7 @@ and path_extension_constructor = Pident ident_extension_constructor and path_floatarray = Pident ident_floatarray and path_promise = Pident ident_promise +and path_uncurried = Pident ident_uncurried let type_int = newgenty (Tconstr(path_int, [], ref Mnil)) and type_char = newgenty (Tconstr(path_char, [], ref Mnil)) diff --git a/jscomp/ml/predef.mli b/jscomp/ml/predef.mli index a3f15f9071..c19bb68733 100644 --- a/jscomp/ml/predef.mli +++ b/jscomp/ml/predef.mli @@ -55,6 +55,7 @@ val path_lazy_t: Path.t val path_extension_constructor: Path.t val path_floatarray: Path.t val path_promise: Path.t +val path_uncurried: Path.t val path_match_failure: Path.t val path_assert_failure : Path.t diff --git a/jscomp/ml/typecore.ml b/jscomp/ml/typecore.ml index 59ded57213..ae3ce1391e 100644 --- a/jscomp/ml/typecore.ml +++ b/jscomp/ml/typecore.ml @@ -307,7 +307,9 @@ let extract_concrete_record env ty = let extract_concrete_variant env ty = match extract_concrete_typedecl env ty with - (p0, p, {type_kind=Type_variant cstrs}) -> (p0, p, cstrs) + (p0, p, {type_kind=Type_variant cstrs}) + when not (Ast_uncurried.typeIsUncurriedFun ty) + -> (p0, p, cstrs) | (p0, p, {type_kind=Type_open}) -> (p0, p, []) | _ -> raise Not_found @@ -662,6 +664,9 @@ let rec collect_missing_arguments env type1 type2 = match type1 with | Some res -> Some ((label, argtype) :: res) | None -> None end + | t when Ast_uncurried.typeIsUncurriedFun t -> + let typ = Ast_uncurried.typeExtractUncurriedFun t in + collect_missing_arguments env typ type2 | _ -> None let print_expr_type_clash ?typeClashContext env trace ppf = begin diff --git a/jscomp/syntax/src/jsx_common.ml b/jscomp/syntax/src/jsx_common.ml index 5dd8d2f090..5379e10e52 100644 --- a/jscomp/syntax/src/jsx_common.ml +++ b/jscomp/syntax/src/jsx_common.ml @@ -49,7 +49,7 @@ let optionalAttr = ({txt = "res.optional"; loc = Location.none}, PStr []) let extractUncurried typ = if Ast_uncurried.coreTypeIsUncurriedFun typ then - let _arity, t = Ast_uncurried.typeExtractUncurriedFun typ in + let _arity, t = Ast_uncurried.coreTypeExtractUncurriedFun typ in t else typ diff --git a/jscomp/syntax/src/res_printer.ml b/jscomp/syntax/src/res_printer.ml index 23c226dabb..c7a715f8ce 100644 --- a/jscomp/syntax/src/res_printer.ml +++ b/jscomp/syntax/src/res_printer.ml @@ -1671,7 +1671,7 @@ and printTypExpr ~(state : State.t) (typExpr : Parsetree.core_type) cmtTbl = printObject ~state ~inline:false fields openFlag cmtTbl | Ptyp_arrow _ -> printArrow ~uncurried:false typExpr | Ptyp_constr _ when Ast_uncurried.coreTypeIsUncurriedFun typExpr -> - let arity, tArg = Ast_uncurried.typeExtractUncurriedFun typExpr in + let arity, tArg = Ast_uncurried.coreTypeExtractUncurriedFun typExpr in printArrow ~uncurried:true ~arity tArg | Ptyp_constr (longidentLoc, [{ptyp_desc = Ptyp_object (fields, openFlag)}]) -> From 6b9d9dc6ad270aaf0823d60498d3e6aea81fd93c Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Mon, 25 Mar 2024 10:25:59 +0200 Subject: [PATCH 2/2] Add fix mishandling of uncurried functions in super errors to changelog --- CHANGELOG.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index d896a93f5d..ad4b5c1987 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -12,6 +12,10 @@ # 11.1.0-rc.6 (Unreleased) +#### :bug: Bug Fix + +- Fix mishandling of uncurried functions in super errors. https://github.com/rescript-lang/rescript-compiler/pull/6694 + # 11.1.0-rc.5 #### :bug: Bug Fix