Merge pull request #9783 from lpw25/widen-warning-16

Widen warning 16 to more cases

Changes

@@ -323,6 +323,9 @@ Working version
   prevents the remaining arguments from being uncurried.
   (Hugo Heuzard, review by Leo White)
 
+- #9783: Widen warning 16 to more cases.
+  (Leo White, review by Florian Angeletti)
+
 ### Internal/compiler-libs changes:
 
 - #9216: add Lambda.duplicate which refreshes bound identifiers

testsuite/tests/typing-misc/typecore_nolabel_errors.ml

@@ -27,15 +27,15 @@ Error: The function applied to this argument has type x:'a -> unit
 This argument cannot be applied with label ~y
 |}]
 
-let f ?x ~a ?y ~z = ()
+let f ?x ~a ?y ~z () = ()
 let g = f ?y:None ?x:None ~a:()
 [%%expect {|
-val f : ?x:'a -> a:'b -> ?y:'c -> z:'d -> unit = <fun>
+val f : ?x:'a -> a:'b -> ?y:'c -> z:'d -> unit -> unit = <fun>
 Line 2, characters 13-17:
 2 | let g = f ?y:None ?x:None ~a:()
                  ^^^^
 Error: The function applied to this argument has type
-         ?x:'a -> a:'b -> ?y:'c -> z:'d -> unit
+         ?x:'a -> a:'b -> ?y:'c -> z:'d -> unit -> unit
 This argument cannot be applied with label ?y
   Since OCaml 4.11, optional arguments do not commute when -nolabels is given
 |}]

testsuite/tests/typing-warnings/warning16.ml

@@ -0,0 +1,58 @@
+(* TEST
+   * expect
+*)
+let foo ?x = ()
+[%%expect{|
+Line 1, characters 9-10:
+1 | let foo ?x = ()
+             ^
+Warning 16 [unerasable-optional-argument]: this optional argument cannot be erased.
+val foo : ?x:'a -> unit = <fun>
+|}]
+
+let foo ?x ~y = ()
+[%%expect{|
+Line 1, characters 9-10:
+1 | let foo ?x ~y = ()
+             ^
+Warning 16 [unerasable-optional-argument]: this optional argument cannot be erased.
+val foo : ?x:'a -> y:'b -> unit = <fun>
+|}]
+
+let foo ?x () = ()
+[%%expect{|
+val foo : ?x:'a -> unit -> unit = <fun>
+|}]
+
+let foo ?x ~y () = ()
+[%%expect{|
+val foo : ?x:'a -> y:'b -> unit -> unit = <fun>
+|}]
+
+class bar ?x = object end
+[%%expect{|
+Line 1, characters 11-12:
+1 | class bar ?x = object end
+               ^
+Warning 16 [unerasable-optional-argument]: this optional argument cannot be erased.
+class bar : ?x:'a -> object  end
+|}]
+
+class bar ?x ~y = object end
+[%%expect{|
+Line 1, characters 11-12:
+1 | class bar ?x ~y = object end
+               ^
+Warning 16 [unerasable-optional-argument]: this optional argument cannot be erased.
+class bar : ?x:'a -> y:'b -> object  end
+|}]
+
+class bar ?x () = object end
+[%%expect{|
+class bar : ?x:'a -> unit -> object  end
+|}]
+
+class foo ?x ~y () = object end
+[%%expect{|
+class foo : ?x:'a -> y:'b -> unit -> object  end
+|}]

typing/typeclass.ml

@@ -1049,8 +1049,9 @@ and class_expr_aux cl_num val_env met_env scl =
           end
           pv
       in
-      let not_function = function
-          Cty_arrow _ -> false
+      let rec not_nolabel_function = function
+        | Cty_arrow(Nolabel, _, _) -> false
+        | Cty_arrow(_, _, cty) -> not_nolabel_function cty
         | _ -> true
       in
       let partial =
@@ -1061,7 +1062,7 @@ and class_expr_aux cl_num val_env met_env scl =
       Ctype.raise_nongen_level ();
       let cl = class_expr cl_num val_env' met_env scl' in
       Ctype.end_def ();
-      if Btype.is_optional l && not_function cl.cl_type then
+      if Btype.is_optional l && not_nolabel_function cl.cl_type then
         Location.prerr_warning pat.pat_loc
           Warnings.Unerasable_optional_argument;
       rc {cl_desc = Tcl_fun (l, pat, pv, cl, partial);

typing/typecore.ml

@@ -3788,11 +3788,11 @@ and type_function ?in_function loc attrs env ty_expected_explained l caselist =
   let cases, partial =
     type_cases Value ~in_function:(loc_fun,ty_fun) env ty_arg ty_res
       true loc caselist in
-  let not_function ty =
+  let not_nolabel_function ty =
     let ls, tvar = list_labels env ty in
-    ls = [] && not tvar
+    List.for_all ((<>) Nolabel) ls && not tvar
   in
-  if is_optional l && not_function ty_res then
+  if is_optional l && not_nolabel_function ty_res then
     Location.prerr_warning (List.hd cases).c_lhs.pat_loc
       Warnings.Unerasable_optional_argument;
   let param = name_cases "param" cases in