More partial application warnings

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)

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

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 {
+      let exp =
-        exp_desc = Texp_apply(funct, args);
+        { exp_desc = Texp_apply(funct, args);
-        exp_loc = loc; exp_extra = [];
+          exp_loc = loc; exp_extra = [];
-        exp_type = ty_res;
+          exp_type = ty_res;
-        exp_attributes = sexp.pexp_attributes;
+          exp_attributes = sexp.pexp_attributes;
-        exp_env = env }
+          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

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 =

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