From a35e1832d467832623f5372a1fcac93dc723584d Mon Sep 17 00:00:00 2001
From: Cristiano Calcagno <cristianoc@users.noreply.github.com>
Date: Wed, 18 Dec 2024 18:13:03 +0100
Subject: [PATCH] Prepare to remove `function$`.

---
 compiler/ml/ast_uncurried.ml                  |  5 +++
 compiler/ml/typecore.ml                       | 44 ++++++++++---------
 .../src/expected/TestPpx.res.jsout            |  2 -
 3 files changed, 29 insertions(+), 22 deletions(-)

diff --git a/compiler/ml/ast_uncurried.ml b/compiler/ml/ast_uncurried.ml
index 303adcba74..dd6714849e 100644
--- a/compiler/ml/ast_uncurried.ml
+++ b/compiler/ml/ast_uncurried.ml
@@ -86,3 +86,8 @@ 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_uncurried_type ~env typ =
+  match (Ctype.expand_head env typ).desc with
+  | Tconstr (Pident {name = "function$"}, [t], _) -> t
+  | _ -> typ
diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml
index eafc8ae0ce..99eee497ca 100644
--- a/compiler/ml/typecore.ml
+++ b/compiler/ml/typecore.ml
@@ -3527,34 +3527,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 uncurried -> true
+    | _ -> false
+  in
+  let has_uncurried_type funct =
+    let t = funct.exp_type in
+    let inner_t = Ast_uncurried.remove_uncurried_type ~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_uncurried_type ~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
diff --git a/tests/tools_tests/src/expected/TestPpx.res.jsout b/tests/tools_tests/src/expected/TestPpx.res.jsout
index 3bc187225d..8235042c40 100644
--- a/tests/tools_tests/src/expected/TestPpx.res.jsout
+++ b/tests/tools_tests/src/expected/TestPpx.res.jsout
@@ -41,8 +41,6 @@ async function fpromise(promise, _x) {
 
 let Uncurried = {};
 
-let Uncurried = {};
-
 let a = "A";
 
 let b = "B";