Typecheck x|>f and f @@ x as (f x) (ocaml#10081)

Changes

@@ -85,6 +85,11 @@ Working version
 - #10244: Optimise Int32.unsigned_to_int
   (Fabian Hemmer, review by Stephen Dolan and Xavier Leroy)
 
+### Type system:
+
+* #10081: Typecheck `x |> f` and `f @@ x` as `(f x)`
+  (Alain Frisch, review by Jacques Garrigue, Josh Berdine and Thomas Refis)
+
 ### Standard library:
 
 - #9533: Added String.starts_with and String.ends_with.

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

@@ -2646,6 +2646,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 sexp =
   (* We now delegate everything to type_expect *)
   type_expect ?recarg env sexp (mk_expected (newvar ()))
@@ -2823,25 +2834,42 @@ and type_expect_
         loc sexp.pexp_attributes env ty_expected_explained Nolabel caselist
   | Pexp_apply(sfunct, sargs) ->
       assert (sargs <> []);
-      begin_def (); (* one more level for non-returning functions *)
-      if !Clflags.principal then begin_def ();
-      let funct = type_exp env 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 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 ();
-      lower_args [] ty;
       begin_def ();
       let (args, ty_res) = type_application env funct sargs in
       end_def ();
@@ -4210,6 +4238,7 @@ and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected =
     let ls, tvar = list_labels env ty in
     not tvar && List.for_all ((=) Nolabel) ls
   in
+<<<<<<< HEAD
   let rec is_inferred sexp =
     match sexp.pexp_desc with
       Pexp_ident _ | Pexp_apply _ | Pexp_field _ | Pexp_constraint _
@@ -4221,6 +4250,10 @@ and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected =
   let lv = (repr ty_expected').level in
   match expand_head env (correct_levels ty_expected') with
     {desc = Tarrow(Nolabel,_,ty_res0,_)}
+=======
+  match expand_head env ty_expected' with
+    {desc = Tarrow(Nolabel,ty_arg,ty_res,_); level = lv}
+>>>>>>> 8b8168ee0... Typecheck x|>f and f @@ x as (f x) (#10081)
     when is_inferred sarg ->
       (* apply optional arguments when expected type is "" *)
       (* we must be very careful about not breaking the semantics *)