Fix super error mishandling uncurried function (#6694)

* Fix super error mishandling uncurried function

* Add fix mishandling of uncurried functions in super errors to changelog

Author: JonoPrest

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

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<int>) => 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<int>

jscomp/build_tests/super_errors/fixtures/UncurriedArgsNotApplied.res

@@ -0,0 +1,3 @@
+let apply = (fn: (. unit) => option<int>) => fn(. ())
+
+let _ = apply(Some(1))

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
 

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

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
+
+
+

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
 

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))

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

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