flambda-backend: Protect calling not_nolabel_function, just as it used to be (#2425)

Author: goldfirere

testsuite/tests/typing-gadts/optional_args.ml

@@ -0,0 +1,68 @@
+(* TEST
+   * expect
+*)
+
+(* A bug in typecore leading to extra expansion led this to be rejected. *)
+
+type (_, _) refl = Refl : ('a, 'a) refl
+
+[%%expect{|
+type (_, _) refl = Refl : ('a, 'a) refl
+|}]
+
+let apply (_ : unit -> 'a) : 'a = assert false
+let go (type a) (Refl : (unit, a) refl) = apply (fun () : a -> ())
+
+[%%expect{|
+val apply : (unit -> 'a) -> 'a = <fun>
+val go : (unit, 'a) refl -> 'a = <fun>
+|}]
+
+let apply (_ : x:unit -> unit -> 'a) : 'a = assert false
+let go (type a) (Refl : (unit, a) refl) = apply (fun ~x:_ () : a -> ())
+
+[%%expect{|
+val apply : (x:unit -> unit -> 'a) -> 'a = <fun>
+val go : (unit, 'a) refl -> 'a = <fun>
+|}]
+
+let apply (_ : ?x:unit -> unit -> 'a) : 'a = assert false
+let go (type a) (Refl : (unit, a) refl) = apply (fun ?x:_ () : a -> ())
+
+[%%expect{|
+val apply : (?x:unit -> unit -> 'a) -> 'a = <fun>
+Line 2, characters 42-71:
+2 | let go (type a) (Refl : (unit, a) refl) = apply (fun ?x:_ () : a -> ())
+                                              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This expression has type a = unit
+       but an expression was expected of type 'a
+       This instance of unit is ambiguous:
+       it would escape the scope of its equation
+|}]
+
+let apply (_ : unit -> x:unit -> 'a) : 'a = assert false
+let go (type a) (Refl : (unit, a) refl) = apply (fun () ~x:_ : a -> ())
+
+[%%expect{|
+val apply : (unit -> x:unit -> 'a) -> 'a = <fun>
+val go : (unit, 'a) refl -> 'a = <fun>
+|}]
+
+let apply (_ : unit -> ?x:unit -> 'a) : 'a = assert false
+let go (type a) (Refl : (unit, a) refl) = apply (fun () ?x:_ : a -> ())
+
+[%%expect{|
+val apply : (unit -> ?x:unit -> 'a) -> 'a = <fun>
+Line 2, characters 59-60:
+2 | let go (type a) (Refl : (unit, a) refl) = apply (fun () ?x:_ : a -> ())
+                                                               ^
+Warning 16 [unerasable-optional-argument]: this optional argument cannot be erased.
+
+Line 2, characters 42-71:
+2 | let go (type a) (Refl : (unit, a) refl) = apply (fun () ?x:_ : a -> ())
+                                              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This expression has type a = unit
+       but an expression was expected of type 'a
+       This instance of unit is ambiguous:
+       it would escape the scope of its equation
+|}]

typing/typecore.ml

@@ -6762,16 +6762,17 @@ and type_function
          there might be an opportunity to improve this.
       *)
       let not_nolabel_function ty =
+        (* [list_labels] does expansion and is potentially expensive; only
+           call this when necessary. *)
         let ls, tvar = list_labels env ty in
         List.for_all (( <> ) Nolabel) ls && not tvar
       in
-      if not_nolabel_function ty_ret then
-        if is_optional typed_arg_label then
-          Location.prerr_warning pat.pat_loc
-            Warnings.Unerasable_optional_argument
-        else if is_position typed_arg_label then
-          Location.prerr_warning pat.pat_loc
-            Warnings.Unerasable_position_argument;
+      if is_optional typed_arg_label && not_nolabel_function ty_ret then
+        Location.prerr_warning pat.pat_loc
+          Warnings.Unerasable_optional_argument
+      else if is_position typed_arg_label && not_nolabel_function ty_ret then
+        Location.prerr_warning pat.pat_loc
+          Warnings.Unerasable_position_argument;
       let fp_kind, fp_param =
         match default_arg with
         | None ->
@@ -9838,7 +9839,7 @@ let report_error ~loc env = function
         | Nolabel, _ | _, Nolabel -> true
         | _                       -> false
       in
-      let maybe_positional_argument_hint = 
+      let maybe_positional_argument_hint =
         match got, expected with
         | Labelled _, Position _ ->
           "\nHint: Consider explicitly annotating the label with '[%call_pos]'"