From 56703cd2905b42a6170a7d3e9426d328dc4b3c4b Mon Sep 17 00:00:00 2001 From: Stephen Dolan Date: Wed, 27 Oct 2021 15:24:39 +0100 Subject: [PATCH] Port ocaml/ocaml#10081 Typecheck x|>f and f @@ x as (f x) (cherry picked from commit 8b8168ee097aa15e0148816984279220526f970f) --- testsuite/tests/prim-revapply/apply.ml | 5 ++ testsuite/tests/prim-revapply/revapply.ml | 11 ++++ testsuite/tests/typing-misc/printing.ml | 4 +- typing/typecore.ml | 69 ++++++++++++++--------- 4 files changed, 61 insertions(+), 28 deletions(-) diff --git a/testsuite/tests/prim-revapply/apply.ml b/testsuite/tests/prim-revapply/apply.ml index 4f947d9771a..94a17b272b9 100644 --- a/testsuite/tests/prim-revapply/apply.ml +++ b/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 *) diff --git a/testsuite/tests/prim-revapply/revapply.ml b/testsuite/tests/prim-revapply/revapply.ml index 32435562afd..4a72154724d 100644 --- a/testsuite/tests/prim-revapply/revapply.ml +++ b/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 diff --git a/testsuite/tests/typing-misc/printing.ml b/testsuite/tests/typing-misc/printing.ml index 526bfa8fea6..0def4d44e99 100644 --- a/testsuite/tests/typing-misc/printing.ml +++ b/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. |}] diff --git a/typing/typecore.ml b/typing/typecore.ml index 75c0446f4cb..99447c6cfc6 100644 --- a/typing/typecore.ml +++ b/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 ->