Port ocaml#10081

Typecheck x|>f and f @@ x as (f x)

(cherry picked from commit 8b8168e)

testsuite/tests/prim-revapply/apply.ml

@@ -1,4 +1,5 @@
 (* TEST
+   flags="-w +48"
 *)
 
 external ( @@ ) :  ('a -> 'b) -> 'a -> 'b = "%apply"
@@ -37,3 +38,7 @@ let _ =
       h @@ g @@ f @@ 3; (* 37 *)
       add 4 @@ g @@ f @@ add 3 @@ add 2 @@ 3; (* 260 *)
     ]
+
+(* PR#10081 *)
+let bump ?(cap = 100) x = min cap (x + 1)
+let _f x = bump @@ x (* no warning 48 *)

testsuite/tests/prim-revapply/revapply.ml

@@ -1,4 +1,5 @@
 (* TEST
+   flags="-w +48"
 *)
 
 external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
@@ -19,3 +20,13 @@ let _ =
       3 |> f |> g |> h; (* 37 *)
       3 |> add 2 |> add 3 |> f |> g |> add 4; (* 260 *)
     ]
+
+
+(* PR#10081 *)
+let bump ?(cap = 100) x = min cap (x + 1)
+let _f x = x |> bump (* no warning 48 *)
+
+(* PR#10081 *)
+type t = A | B
+type s = A | B
+let _f (x : t) = x |> function A -> 0 | B -> 1

testsuite/tests/typing-misc/printing.ml

@@ -113,6 +113,6 @@ and bar () =
 Line 4, characters 7-29:
 4 |   x |> List.fold_left max 0 x
            ^^^^^^^^^^^^^^^^^^^^^^
-Error: This expression has type int but an expression was expected of type
-         int list -> 'a
+Error: This expression has type int
+       This is not a function; it cannot be applied.
 |}]

typing/typecore.ml

@@ -2638,6 +2638,17 @@ let unify_exp env exp expected_ty =
   with Error(loc, env, Expr_type_clash(trace, tfc, None)) ->
     raise (Error(loc, env, Expr_type_clash(trace, tfc, Some exp.exp_desc)))
 
+(* If [is_inferred e] is true, [e] will be typechecked without using
+   the "expected type" provided by the context. *)
+
+let rec is_inferred sexp =
+  match sexp.pexp_desc with
+  | Pexp_ident _ | Pexp_apply _ | Pexp_field _ | Pexp_constraint _
+  | Pexp_coerce _ | Pexp_send _ | Pexp_new _ -> true
+  | Pexp_sequence (_, e) | Pexp_open (_, e) -> is_inferred e
+  | Pexp_ifthenelse (_, e1, Some e2) -> is_inferred e1 && is_inferred e2
+  | _ -> false
+
 let rec type_exp ?recarg env (mode : expected_mode) sexp =
   (* We now delegate everything to type_expect *)
   type_expect ?recarg env mode sexp (mk_expected (newvar ()))
@@ -2834,30 +2845,47 @@ and type_expect_
         (Nontail alloc_local) e ty_expected_explained
   | Pexp_apply(sfunct, sargs) ->
       assert (sargs <> []);
-      begin_def (); (* one more level for non-returning functions *)
-      if !Clflags.principal then begin_def ();
       let funct_mode =
         match mode with
         | Nontail _ -> Alloc_mode.newvar ()
         | Tail _ -> Alloc_mode.heap
       in
-      let funct = type_exp env (Nontail funct_mode) sfunct in
-      if !Clflags.principal then begin
-          end_def ();
-          generalize_structure funct.exp_type
-        end;
       let rec lower_args seen ty_fun =
         let ty = expand_head env ty_fun in
         if List.memq ty seen then () else
-        match ty.desc with
-          Tarrow (_l, ty_arg, ty_fun, _com) ->
-            (try unify_var env (newvar()) ty_arg with Unify _ -> assert false);
-            lower_args (ty::seen) ty_fun
-        | _ -> ()
+          match ty.desc with
+            Tarrow (_l, ty_arg, ty_fun, _com) ->
+              (try unify_var env (newvar()) ty_arg
+               with Unify _ -> assert false);
+              lower_args (ty::seen) ty_fun
+          | _ -> ()
+      in
+      let type_sfunct sfunct =
+        begin_def (); (* one more level for non-returning functions *)
+        if !Clflags.principal then begin_def ();
+        let funct = type_exp env (Nontail funct_mode) sfunct in
+        if !Clflags.principal then begin
+          end_def ();
+          generalize_structure funct.exp_type
+        end;
+        let ty = instance funct.exp_type in
+        end_def ();
+        wrap_trace_gadt_instances env (lower_args []) ty;
+        funct
+      in
+      let funct, sargs =
+        let funct = type_sfunct sfunct in
+        match funct.exp_desc, sargs with
+        | Texp_ident (_, _, {val_kind = Val_prim {prim_name = "%revapply"}}),
+          [Nolabel, sarg; Nolabel, actual_sfunct]
+          when is_inferred actual_sfunct ->
+            type_sfunct actual_sfunct, [Nolabel, sarg]
+        | Texp_ident (_, _, {val_kind = Val_prim {prim_name = "%apply"}}),
+          [Nolabel, actual_sfunct; Nolabel, sarg] ->
+            type_sfunct actual_sfunct, [Nolabel, sarg]
+        | _ ->
+            funct, sargs
       in
-      let ty = instance funct.exp_type in
-      end_def ();
-      wrap_trace_gadt_instances env (lower_args []) ty;
       begin_def ();
       let (args, ty_res) = type_application env loc mode funct sargs in
       end_def ();
@@ -4346,17 +4374,6 @@ and type_argument ?explanation ?recarg env mode sarg ty_expected' ty_expected =
     let ls, tvar = list_labels env ty in
     not tvar && List.for_all ((=) Nolabel) ls
   in
-  let rec is_inferred sexp =
-    match sexp.pexp_desc with
-    | Pexp_apply
-        ({ pexp_desc = Pexp_extension({txt = "stack"}, PStr []) },
-         [Nolabel, _]) -> false
-    | Pexp_ident _ | Pexp_apply _ | Pexp_field _ | Pexp_constraint _
-    | Pexp_coerce _ | Pexp_send _ | Pexp_new _ -> true
-    | Pexp_sequence (_, e) | Pexp_open (_, e) -> is_inferred e
-    | Pexp_ifthenelse (_, e1, Some e2) -> is_inferred e1 && is_inferred e2
-    | _ -> false
-  in
   match expand_head env ty_expected' with
     {desc = Tarrow((Nolabel,marg,mret),ty_arg,ty_res,_); level = lv}
     when is_inferred sarg ->