From fd1bb255e1faef66546a4d2d785a14c28f004b13 Mon Sep 17 00:00:00 2001
From: Stephen Dolan <sdolan@janestreet.com>
Date: Wed, 13 May 2020 13:26:43 +0100
Subject: [PATCH] More partial application warnings

---
 Changes                                       |  4 ++++
 .../tests/typing-warnings/application.ml      | 20 +++++++++++++++++++
 typing/typecore.ml                            | 18 +++++++++++------
 utils/misc.ml                                 |  5 +++++
 utils/misc.mli                                |  4 ++++
 5 files changed, 45 insertions(+), 6 deletions(-)

diff --git a/Changes b/Changes
index b36911328..7efe0e73d 100644
--- a/Changes
+++ b/Changes
@@ -86,6 +86,10 @@ Working version
 
 ### Compiler user-interface and warnings:
 
+- #9560: Report partial application warnings on type errors in applications.
+  (Stephen Dolan, report and testcase by whitequark, review by Gabriel Scherer
+   and Thomas Refis)
+
 - #9583: when bytecode linking fails due to an unavailable module, the module
   that requires it is now included in the error message.
   (Nicolás Ojeda Bär, review by Vincent Laviron)
diff --git a/testsuite/tests/typing-warnings/application.ml b/testsuite/tests/typing-warnings/application.ml
index 6a5105f73..7022eb80b 100644
--- a/testsuite/tests/typing-warnings/application.ml
+++ b/testsuite/tests/typing-warnings/application.ml
@@ -84,3 +84,23 @@ Line 1, characters 19-20:
 Warning 20: this argument will not be used by the function.
 Exception: Stdlib.Exit.
 |}]
+
+let f a b = a + b;;
+[%%expect {|
+val f : int -> int -> int = <fun>
+|}]
+let g x = x + 1
+let _ = g (f 1);;
+[%%expect {|
+val g : int -> int = <fun>
+Line 2, characters 10-15:
+2 | let _ = g (f 1);;
+              ^^^^^
+Warning 5: this function application is partial,
+maybe some arguments are missing.
+Line 2, characters 10-15:
+2 | let _ = g (f 1);;
+              ^^^^^
+Error: This expression has type int -> int
+       but an expression was expected of type int
+|}]
diff --git a/typing/typecore.ml b/typing/typecore.ml
index b760fe0e1..615729c60 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -2709,12 +2709,18 @@ and type_expect_
       let (args, ty_res) = type_application env funct sargs in
       end_def ();
       unify_var env (newvar()) funct.exp_type;
-      rue {
-        exp_desc = Texp_apply(funct, args);
-        exp_loc = loc; exp_extra = [];
-        exp_type = ty_res;
-        exp_attributes = sexp.pexp_attributes;
-        exp_env = env }
+      let exp =
+        { exp_desc = Texp_apply(funct, args);
+          exp_loc = loc; exp_extra = [];
+          exp_type = ty_res;
+          exp_attributes = sexp.pexp_attributes;
+          exp_env = env } in
+      begin
+        try rue exp
+        with Error (_, _, Expr_type_clash _) as err ->
+          Misc.reraise_preserving_backtrace err (fun () ->
+            check_partial_application false exp)
+      end
   | Pexp_match(sarg, caselist) ->
       begin_def ();
       let arg = type_exp env sarg in
diff --git a/utils/misc.ml b/utils/misc.ml
index d2230270a..40979030b 100644
--- a/utils/misc.ml
+++ b/utils/misc.ml
@@ -49,6 +49,11 @@ let try_finally ?(always=(fun () -> ())) ?(exceptionally=(fun () -> ())) work =
           Printexc.raise_with_backtrace always_exn always_bt
       end
 
+let reraise_preserving_backtrace e f =
+  let bt = Printexc.get_raw_backtrace () in
+  f ();
+  Printexc.raise_with_backtrace e bt
+
 type ref_and_value = R : 'a ref * 'a -> ref_and_value
 
 let protect_refs =
diff --git a/utils/misc.mli b/utils/misc.mli
index c15885cfa..a2fdb573b 100644
--- a/utils/misc.mli
+++ b/utils/misc.mli
@@ -59,6 +59,10 @@ val try_finally :
     for easier debugging.
 *)
 
+val reraise_preserving_backtrace : exn -> (unit -> unit) -> 'a
+(** [reraise_preserving_backtrace e f] is (f (); raise e) except that the
+    current backtrace is preserved, even if [f] uses exceptions internally. *)
+
 
 val map_end: ('a -> 'b) -> 'a list -> 'b list -> 'b list
         (* [map_end f l t] is [map f l @ t], just more efficient. *)