Skip to content

Commit 0d9efda

Browse files
authored
flambda-backend: Protect calling not_nolabel_function, just as it used to be (#2425)
1 parent bc2db04 commit 0d9efda

File tree

2 files changed

+77
-8
lines changed

2 files changed

+77
-8
lines changed
Lines changed: 68 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,68 @@
1+
(* TEST
2+
* expect
3+
*)
4+
5+
(* A bug in typecore leading to extra expansion led this to be rejected. *)
6+
7+
type (_, _) refl = Refl : ('a, 'a) refl
8+
9+
[%%expect{|
10+
type (_, _) refl = Refl : ('a, 'a) refl
11+
|}]
12+
13+
let apply (_ : unit -> 'a) : 'a = assert false
14+
let go (type a) (Refl : (unit, a) refl) = apply (fun () : a -> ())
15+
16+
[%%expect{|
17+
val apply : (unit -> 'a) -> 'a = <fun>
18+
val go : (unit, 'a) refl -> 'a = <fun>
19+
|}]
20+
21+
let apply (_ : x:unit -> unit -> 'a) : 'a = assert false
22+
let go (type a) (Refl : (unit, a) refl) = apply (fun ~x:_ () : a -> ())
23+
24+
[%%expect{|
25+
val apply : (x:unit -> unit -> 'a) -> 'a = <fun>
26+
val go : (unit, 'a) refl -> 'a = <fun>
27+
|}]
28+
29+
let apply (_ : ?x:unit -> unit -> 'a) : 'a = assert false
30+
let go (type a) (Refl : (unit, a) refl) = apply (fun ?x:_ () : a -> ())
31+
32+
[%%expect{|
33+
val apply : (?x:unit -> unit -> 'a) -> 'a = <fun>
34+
Line 2, characters 42-71:
35+
2 | let go (type a) (Refl : (unit, a) refl) = apply (fun ?x:_ () : a -> ())
36+
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
37+
Error: This expression has type a = unit
38+
but an expression was expected of type 'a
39+
This instance of unit is ambiguous:
40+
it would escape the scope of its equation
41+
|}]
42+
43+
let apply (_ : unit -> x:unit -> 'a) : 'a = assert false
44+
let go (type a) (Refl : (unit, a) refl) = apply (fun () ~x:_ : a -> ())
45+
46+
[%%expect{|
47+
val apply : (unit -> x:unit -> 'a) -> 'a = <fun>
48+
val go : (unit, 'a) refl -> 'a = <fun>
49+
|}]
50+
51+
let apply (_ : unit -> ?x:unit -> 'a) : 'a = assert false
52+
let go (type a) (Refl : (unit, a) refl) = apply (fun () ?x:_ : a -> ())
53+
54+
[%%expect{|
55+
val apply : (unit -> ?x:unit -> 'a) -> 'a = <fun>
56+
Line 2, characters 59-60:
57+
2 | let go (type a) (Refl : (unit, a) refl) = apply (fun () ?x:_ : a -> ())
58+
^
59+
Warning 16 [unerasable-optional-argument]: this optional argument cannot be erased.
60+
61+
Line 2, characters 42-71:
62+
2 | let go (type a) (Refl : (unit, a) refl) = apply (fun () ?x:_ : a -> ())
63+
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
64+
Error: This expression has type a = unit
65+
but an expression was expected of type 'a
66+
This instance of unit is ambiguous:
67+
it would escape the scope of its equation
68+
|}]

typing/typecore.ml

Lines changed: 9 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -6762,16 +6762,17 @@ and type_function
67626762
there might be an opportunity to improve this.
67636763
*)
67646764
let not_nolabel_function ty =
6765+
(* [list_labels] does expansion and is potentially expensive; only
6766+
call this when necessary. *)
67656767
let ls, tvar = list_labels env ty in
67666768
List.for_all (( <> ) Nolabel) ls && not tvar
67676769
in
6768-
if not_nolabel_function ty_ret then
6769-
if is_optional typed_arg_label then
6770-
Location.prerr_warning pat.pat_loc
6771-
Warnings.Unerasable_optional_argument
6772-
else if is_position typed_arg_label then
6773-
Location.prerr_warning pat.pat_loc
6774-
Warnings.Unerasable_position_argument;
6770+
if is_optional typed_arg_label && not_nolabel_function ty_ret then
6771+
Location.prerr_warning pat.pat_loc
6772+
Warnings.Unerasable_optional_argument
6773+
else if is_position typed_arg_label && not_nolabel_function ty_ret then
6774+
Location.prerr_warning pat.pat_loc
6775+
Warnings.Unerasable_position_argument;
67756776
let fp_kind, fp_param =
67766777
match default_arg with
67776778
| None ->
@@ -9838,7 +9839,7 @@ let report_error ~loc env = function
98389839
| Nolabel, _ | _, Nolabel -> true
98399840
| _ -> false
98409841
in
9841-
let maybe_positional_argument_hint =
9842+
let maybe_positional_argument_hint =
98429843
match got, expected with
98439844
| Labelled _, Position _ ->
98449845
"\nHint: Consider explicitly annotating the label with '[%call_pos]'"

0 commit comments

Comments
 (0)