[%call_pos] application via an optional argument results in an error

ocaml/testsuite/tests/typing-implicit-source-positions/application_via_option.ml

@@ -0,0 +1,119 @@
+(* TEST_BELOW
+Fille
+*)
+
+let f = fun ~(call_pos:[%call_pos]) () -> call_pos
+[%%expect {|
+val f : call_pos:[%call_pos] -> unit -> lexing_position = <fun>
+|}]
+
+let _ = f ?call_pos:None ();
+[%%expect {|
+Line 1, characters 20-24:
+1 | let _ = f ?call_pos:None ();
+                        ^^^^
+Error: the argument labeled 'call_pos' is a [%call_pos] argument, filled in
+       automatically if ommitted. It cannot be passed with '?'.
+|}]
+
+let _ =
+  let pos = f () in
+  f ?call_pos:(Some pos) ();
+[%%expect {|
+Line 3, characters 14-24:
+3 |   f ?call_pos:(Some pos) ();
+                  ^^^^^^^^^^
+Error: the argument labeled 'call_pos' is a [%call_pos] argument, filled in
+       automatically if ommitted. It cannot be passed with '?'.
+|}]
+
+let ( >>| ) ~(call_pos : [%call_pos]) a b = a + b, call_pos ;;
+[%%expect {|
+val ( >>| ) : call_pos:[%call_pos] -> int -> int -> int * lexing_position =
+  <fun>
+|}]
+
+let _ =  ( >>| ) ?call_pos:None 1 2 ;;
+[%%expect {|
+Line 1, characters 27-31:
+1 | let _ =  ( >>| ) ?call_pos:None 1 2 ;;
+                               ^^^^
+Error: the argument labeled 'call_pos' is a [%call_pos] argument, filled in
+       automatically if ommitted. It cannot be passed with '?'.
+|}]
+
+let _ =
+  let pos = f () in
+  ( >>| ) ?call_pos:(Some pos) 1 2
+;;
+[%%expect {|
+Line 3, characters 20-30:
+3 |   ( >>| ) ?call_pos:(Some pos) 1 2
+                        ^^^^^^^^^^
+Error: the argument labeled 'call_pos' is a [%call_pos] argument, filled in
+       automatically if ommitted. It cannot be passed with '?'.
+|}]
+
+class c ~(call_pos : [%call_pos]) () = object 
+  method call_pos = call_pos
+end
+[%%expect {|
+class c :
+  call_pos:[%call_pos] ->
+  unit -> object method call_pos : lexing_position end
+|}]
+
+let _ = (new c ?call_pos:None ())#call_pos;;
+[%%expect {|
+Line 1, characters 25-29:
+1 | let _ = (new c ?call_pos:None ())#call_pos;;
+                             ^^^^
+Error: the argument labeled 'call_pos' is a [%call_pos] argument, filled in
+       automatically if ommitted. It cannot be passed with '?'.
+|}]
+
+let _ = 
+  let pos = f () in
+  (new c ?call_pos:(Some pos) ())#call_pos;;
+[%%expect {|
+Line 3, characters 19-29:
+3 |   (new c ?call_pos:(Some pos) ())#call_pos;;
+                       ^^^^^^^^^^
+Error: the argument labeled 'call_pos' is a [%call_pos] argument, filled in
+       automatically if ommitted. It cannot be passed with '?'.
+|}]
+
+class parent ~(call_pos : [%call_pos]) () = object
+  method pos = call_pos
+end
+[%%expect {|
+class parent :
+  call_pos:[%call_pos] -> unit -> object method pos : lexing_position end
+|}]
+
+let _ = (object 
+  inherit parent ?call_pos:None ()
+end)#pos;;
+[%%expect {|
+Line 2, characters 27-31:
+2 |   inherit parent ?call_pos:None ()
+                               ^^^^
+Error: the argument labeled 'call_pos' is a [%call_pos] argument, filled in
+       automatically if ommitted. It cannot be passed with '?'.
+|}]
+
+let o = (object 
+  inherit parent ?call_pos:(Some (f ())) ()
+end)#pos
+[%%expect {|
+Line 2, characters 27-40:
+2 |   inherit parent ?call_pos:(Some (f ())) ()
+                               ^^^^^^^^^^^^^
+Error: the argument labeled 'call_pos' is a [%call_pos] argument, filled in
+       automatically if ommitted. It cannot be passed with '?'.
+|}]
+
+
+(* TEST
+ expect;
+*)

ocaml/typing/typeclass.ml

@@ -110,6 +110,7 @@ type error =
   | Polymorphic_class_parameter
   | Non_value_binding of string * Jkind.Violation.t
   | Non_value_let_binding of string * Jkind.sort
+  | Nonoptional_call_pos_label of string
 
 exception Error of Location.t * Env.t * error
 exception Error_forward of Location.error
@@ -1359,10 +1360,17 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl =
               end else
                 match Btype.extract_label name sargs with
                 | Some (l', sarg, _, remaining_sargs) ->
-                    if not optional && Btype.is_optional l' then
-                      Location.prerr_warning sarg.pexp_loc
-                        (Warnings.Nonoptional_label
-                           (Printtyp.string_of_label l));
+                    if not optional && Btype.is_optional l' then (
+                      let label = Printtyp.string_of_label l in
+                      if Btype.is_position l then
+                        raise
+                          (Error
+                             ( sarg.pexp_loc
+                             , val_env
+                             , Nonoptional_call_pos_label label))
+                      else
+                        Location.prerr_warning sarg.pexp_loc
+                          (Warnings.Nonoptional_label label));
                     remaining_sargs, use_arg sarg l'
                 | None ->
                     let is_erased () = List.mem_assoc Nolabel sargs in
@@ -2328,6 +2336,10 @@ let report_error env ppf = function
       "@[The types of variables bound by a 'let' in a class function@ \
        must have layout value. Instead, %s's type has layout %a.@]"
       nm Jkind.Sort.format sort
+  | Nonoptional_call_pos_label label ->
+    fprintf ppf
+      "@[the argument labeled '%s' is a [%%call_pos] argument, filled in @ \
+         automatically if ommitted. It cannot be passed with '?'.@]" label
 
 let report_error env ppf err =
   Printtyp.wrap_printing_env ~error:true

ocaml/typing/typeclass.mli

@@ -128,6 +128,7 @@ type error =
   | Polymorphic_class_parameter
   | Non_value_binding of string * Jkind.Violation.t
   | Non_value_let_binding of string * Jkind.sort
+  | Nonoptional_call_pos_label of string
 
 exception Error of Location.t * Env.t * error
 exception Error_forward of Location.error

ocaml/typing/typecore.ml

@@ -230,6 +230,7 @@ type error =
   | Function_type_not_rep of type_expr * Jkind.Violation.t
   | Modes_on_pattern
   | Invalid_label_for_src_pos of arg_label
+  | Nonoptional_call_pos_label of string
 
 exception Error of Location.t * Env.t * error
 exception Error_forward of Location.error
@@ -3646,9 +3647,19 @@ let collect_apply_args env funct ignore_labels ty_fun ty_fun0 mode_fun sargs ret
                   may_warn sarg.pexp_loc
                     (Warnings.Not_principal "commuting this argument")
                 end;
-                if not optional && is_optional l' then
-                  Location.prerr_warning sarg.pexp_loc
-                    (Warnings.Nonoptional_label (Printtyp.string_of_label l));
+                if not optional && is_optional l' then (
+                  let label = Printtyp.string_of_label l in
+                  if is_position l
+                  then
+                    raise
+                      (Error
+                         ( sarg.pexp_loc
+                         , env
+                         , Nonoptional_call_pos_label label))
+                  else
+                    Location.prerr_warning
+                      sarg.pexp_loc
+                      (Warnings.Nonoptional_label label));
                 remaining_sargs, use_arg ~commuted sarg l'
             | None ->
                 sargs,
@@ -10210,6 +10221,10 @@ let report_error ~loc env = function
         | Nolabel -> "unlabelled"
         | Optional _ -> "optional"
         | Labelled _ | Position _ -> assert false )
+  | Nonoptional_call_pos_label label ->
+    Location.errorf ~loc
+      "@[the argument labeled '%s' is a [%%call_pos] argument, filled in @ \
+         automatically if ommitted. It cannot be passed with '?'.@]" label
 
 let report_error ~loc env err =
   Printtyp.wrap_printing_env ~error:true env

ocaml/typing/typecore.mli

@@ -295,6 +295,7 @@ type error =
   | Function_type_not_rep of type_expr * Jkind.Violation.t
   | Modes_on_pattern
   | Invalid_label_for_src_pos of arg_label
+  | Nonoptional_call_pos_label of string
 
 exception Error of Location.t * Env.t * error
 exception Error_forward of Location.error