Implicitly supply source position arguments

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

@@ -0,0 +1,81 @@
+(* TEST
+   * expect
+*)
+
+let f = fun ~(src_pos:[%src_pos]) () -> src_pos
+[%%expect{|
+val f : src_pos:[%src_pos] -> unit -> lexing_position = <fun>
+|}]
+
+let _ = f ();;
+[%%expect{|
+- : lexing_position =
+{pos_fname = ""; pos_lnum = 1; pos_bol = 151; pos_cnum = 159}
+|}]
+
+let j = (f : unit -> lexing_position);;
+[%%expect{|
+val j : unit -> lexing_position = <fun>
+|}]
+
+let g = fun ~(a:[%src_pos]) ?(c = 0) ~(b:[%src_pos]) () -> a, b
+[%%expect{|
+val g :
+  a:[%src_pos] ->
+  ?c:int -> b:[%src_pos] -> unit -> lexing_position * lexing_position = <fun>
+|}]
+
+let _ = g () ;;
+[%%expect{|
+- : lexing_position * lexing_position =
+({pos_fname = ""; pos_lnum = 1; pos_bol = 549; pos_cnum = 557},
+ {pos_fname = ""; pos_lnum = 1; pos_bol = 549; pos_cnum = 557})
+|}]
+
+let h ~(a:[%src_pos]) ~(b:[%src_pos]) () : lexing_position * lexing_position
+  = a, b
+[%%expect{|
+val h :
+  a:[%src_pos] -> b:[%src_pos] -> unit -> lexing_position * lexing_position =
+  <fun>
+|}]
+
+(* Partial application *)
+let x = h ~b:{Lexing.dummy_pos with pos_fname = "b"};;
+[%%expect{|
+val x : a:[%src_pos] -> unit -> lexing_position * lexing_position = <fun>
+|}]
+
+let y = x ();;
+[%%expect{|
+val y : lexing_position * lexing_position =
+  ({pos_fname = ""; pos_lnum = 1; pos_bol = 1119; pos_cnum = 1127},
+   {pos_fname = "b"; pos_lnum = 0; pos_bol = 0; pos_cnum = -1})
+|}]
+
+let k = (f : unit -> lexing_position);;
+[%%expect{|
+val k : unit -> lexing_position = <fun>
+|}]
+
+let _ = j ();;
+[%%expect{|
+- : lexing_position =
+{pos_fname = ""; pos_lnum = 1; pos_bol = 267; pos_cnum = 276}
+|}]
+
+let _ = k ();;
+[%%expect{|
+- : lexing_position =
+{pos_fname = ""; pos_lnum = 1; pos_bol = 1327; pos_cnum = 1336}
+|}]
+
+let m ~(src_pos:[%src_pos]) = ()
+[%%expect {|
+Line 1, characters 8-15:
+1 | let m ~(src_pos:[%src_pos]) = ()
+            ^^^^^^^
+Warning 189 [unerasable-position-argument]: this position argument cannot be erased.
+val m : src_pos:[%src_pos] -> unit = <fun>
+|}]
+

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

@@ -76,3 +76,18 @@ Error: This function should have type src_pos:[%src_pos] -> unit -> unit
        but its first argument is labeled ~src_pos
        instead of ~(src_pos:[%src_pos])
 |}]
+
+let n = fun ~(src_pos:[%src_pos]) () -> src_pos
+[%%expect{|
+val n : src_pos:[%src_pos] -> unit -> lexing_position = <fun>
+|}]
+
+let _ = n Lexing.dummy_pos ();;
+[%%expect {|
+Line 1, characters 27-29:
+1 | let _ = n Lexing.dummy_pos ();;
+                               ^^
+Error: The function applied to this argument has type
+         src_pos:[%src_pos] -> lexing_position
+This argument cannot be applied without label
+|}]

ocaml/testsuite/tests/typing-misc/labels.ml

@@ -104,7 +104,7 @@ val f : (?x:int -> unit -> int) -> int = <fun>
 Line 1, characters 46-47:
 1 | let f g = ignore (g : ?x:int -> unit -> int); g ();;
                                                   ^
-Warning 19 [non-principal-labels]: eliminated optional argument without principality.
+Warning 19 [non-principal-labels]: eliminated omittable argument without principality.
 val f : (?x:int -> unit -> int) -> int = <fun>
 |}];;
 

ocaml/toplevel/topdirs.ml

@@ -190,7 +190,7 @@ exception Bad_printing_function
 let filter_arrow ty =
   let ty = Ctype.expand_head !toplevel_env ty in
   match get_desc ty with
-  | Tarrow ((lbl,_,_), l, r, _) when not (Btype.is_optional lbl) -> Some (l, r)
+  | Tarrow ((lbl,_,_), l, r, _) when not (Btype.is_omittable lbl) -> Some (l, r)
   | _ -> None
 
 let rec extract_last_arrow desc =

ocaml/typing/printtyp.ml

@@ -1123,7 +1123,7 @@ let rec tree_of_typexp mode ty =
         Otyp_var (non_gen, Names.name_of_type name_gen tty)
     | Tarrow ((l, marg, mret), ty1, ty2, _) ->
         let lab =
-          if !print_labels || is_optional l then outcome_label l
+          if !print_labels || is_omittable l then outcome_label l
           else Nolabel
         in
         let t1 =
@@ -1763,7 +1763,7 @@ let rec tree_of_class_type mode params =
       Octy_signature (self_ty, List.rev csil)
   | Cty_arrow (l, ty, cty) ->
       let lab =
-        if !print_labels || is_optional l then outcome_label l
+        if !print_labels || is_omittable l then outcome_label l
         else Nolabel
       in
       let tr =

ocaml/typing/typeclass.ml

@@ -1237,6 +1237,8 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl =
       Ctype.raise_nongen_level ();
       let cl = class_expr cl_num val_env' met_env virt self_scope scl' in
       Ctype.end_def ();
+      (* CR src_pos: The below should probably become is_omittable once
+         classes involve Position arguments *)
       if Btype.is_optional l && not_nolabel_function cl.cl_type then
         Location.prerr_warning pat.pat_loc
           Warnings.Unerasable_optional_argument;

ocaml/typing/typecore.ml

@@ -611,6 +611,14 @@ let extract_option_type env ty =
     Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty
   | _ -> assert false
 
+let src_pos loc attrs env =
+  { exp_desc = Texp_src_pos
+  ; exp_loc = loc
+  ; exp_extra = []
+  ; exp_type = instance Predef.type_lexing_position
+  ; exp_attributes = attrs
+  ; exp_env = env }
+
 type record_extraction_result =
   | Record_type of Path.t * Path.t * Types.label_declaration list * record_representation
   | Not_a_record_type
@@ -3027,7 +3035,8 @@ type untyped_apply_arg =
         mode_fun : Alloc_mode.t;
         mode_arg : Alloc_mode.t; }
   | Eliminated_optional_arg of
-      { mode_fun: Alloc_mode.t;
+      { expected_label : arg_label;
+        mode_fun: Alloc_mode.t;
         ty_arg : type_expr;
         sort_arg : sort;
         mode_arg : Alloc_mode.t;
@@ -3057,7 +3066,7 @@ let remaining_function_type ty_ret mode_ret rev_args =
              let closed_args = mode_arg :: closed_args in
              (ty_ret, mode_ret, closed_args)
          | Arg (Eliminated_optional_arg
-                  { mode_fun; ty_arg; mode_arg; level })
+                  { mode_fun; ty_arg; mode_arg; level; _ })
          | Omitted { mode_fun; ty_arg; mode_arg; level } ->
              let arrow_desc = lbl, mode_arg, mode_ret in
              let ty_ret =
@@ -3130,7 +3139,7 @@ let check_local_application_complete ~env ~app_loc args =
 let collect_unknown_apply_args env funct ty_fun mode_fun rev_args sargs ret_tvar =
   let labels_match ~param ~arg =
     param = arg
-    || !Clflags.classic && arg = Nolabel && not (is_optional param)
+    || !Clflags.classic && arg = Nolabel && not (is_omittable param)
   in
   let has_label l ty_fun =
     let ls, tvar = list_labels env ty_fun in
@@ -3218,7 +3227,8 @@ let collect_apply_args env funct ignore_labels ty_fun ty_fun0 mode_fun sargs ret
                                      Function_type_not_rep(ty_arg, err)))
         in
         let name = label_name l
-        and optional = is_optional l in
+        and optional = is_optional l
+        and omittable = is_omittable l in
         let use_arg ~commuted sarg l' =
           let wrapped_in_some = optional && not (is_optional l') in
           if wrapped_in_some then
@@ -3228,32 +3238,33 @@ let collect_apply_args env funct ignore_labels ty_fun ty_fun0 mode_fun sargs ret
             { sarg; ty_arg; ty_arg0; commuted; sort_arg;
               mode_fun; mode_arg; wrapped_in_some })
         in
-        let eliminate_optional_arg () =
+        let eliminate_omittable_arg expected_label =
           may_warn funct.exp_loc
-            (Warnings.Non_principal_labels "eliminated optional argument");
+            (Warnings.Non_principal_labels "eliminated omittable argument");
           Arg
             (Eliminated_optional_arg
-               { mode_fun; ty_arg; mode_arg; sort_arg; level = lv })
+               { mode_fun; ty_arg; mode_arg
+               ; sort_arg; level = lv; expected_label})
         in
         let remaining_sargs, arg =
           if ignore_labels then begin
             (* No reordering is allowed, process arguments in order *)
             match sargs with
             | [] -> assert false
             | (l', sarg) :: remaining_sargs ->
-                if name = label_name l' || (not optional && l' = Nolabel) then
+                if name = label_name l' || (not omittable && l' = Nolabel) then
                   (remaining_sargs, use_arg ~commuted:false sarg l')
                 else if
-                  optional &&
+                  omittable &&
                   not (List.exists (fun (l, _) -> name = label_name l)
                          remaining_sargs) &&
                   List.exists (function (Nolabel, _) -> true | _ -> false)
                     sargs
                 then
-                  (sargs, eliminate_optional_arg ())
+                  (sargs, eliminate_omittable_arg l)
                 else
                   raise(Error(sarg.pexp_loc, env,
-                              Apply_wrong_label(l', ty_fun', optional)))
+                              Apply_wrong_label(l', ty_fun', omittable)))
           end else
             (* Arguments can be commuted, try to fetch the argument
                corresponding to the first parameter. *)
@@ -3269,8 +3280,8 @@ let collect_apply_args env funct ignore_labels ty_fun ty_fun0 mode_fun sargs ret
                 remaining_sargs, use_arg ~commuted sarg l'
             | None ->
                 sargs,
-                if optional && List.mem_assoc Nolabel sargs then
-                  eliminate_optional_arg ()
+                if omittable && List.mem_assoc Nolabel sargs then
+                  eliminate_omittable_arg l
                 else begin
                   (* No argument was given for this parameter, we abstract over
                      it. *)
@@ -5718,12 +5729,7 @@ and type_expect_
       | _ -> raise (Error (loc, env, Probe_is_enabled_format))
     end
   | Pexp_extension ({ txt = "src_pos"; _ }, _) ->
-      rue {
-        exp_desc = Texp_src_pos;
-        exp_loc = loc; exp_extra = [];
-        exp_type = instance Predef.type_lexing_position;
-        exp_attributes = sexp.pexp_attributes;
-        exp_env = env }
+      rue (src_pos loc sexp.pexp_attributes env)
   | Pexp_extension ext ->
     raise (Error_forward (Builtin_attributes.error_of_extension ext))
 
@@ -5928,9 +5934,13 @@ and type_function ?in_function loc attrs env (expected_mode : expected_mode)
     let ls, tvar = list_labels env ty in
     List.for_all ((<>) Nolabel) ls && not tvar
   in
-  if is_optional arg_label && not_nolabel_function ty_ret then
-    Location.prerr_warning (List.hd cases).c_lhs.pat_loc
-      Warnings.Unerasable_optional_argument;
+  if not_nolabel_function ty_ret then
+    if is_optional arg_label then
+      Location.prerr_warning (List.hd cases).c_lhs.pat_loc
+        Warnings.Unerasable_optional_argument
+    else if is_position arg_label then
+      Location.prerr_warning (List.hd cases).c_lhs.pat_loc
+        Warnings.Unerasable_position_argument;
   let param = name_cases "param" cases in
   let region = region_locked && not uncurried_function in
   let warnings = Warnings.backup () in
@@ -6351,7 +6361,7 @@ and type_argument ?explanation ?recarg env (mode : expected_mode) sarg
   in
   match may_coerce with
     Some (safe_expect, lv) ->
-      (* apply optional arguments when expected type is "" *)
+      (* apply omittable arguments when expected type is "" *)
       (* we must be very careful about not breaking the semantics *)
       if !Clflags.principal then begin_def ();
       let exp_mode = Value_mode.newvar_below mode.mode in
@@ -6370,6 +6380,9 @@ and type_argument ?explanation ?recarg env (mode : expected_mode) sarg
             (* CR layouts v5: change value assumption below when we allow
                non-values in structures. *)
             make_args ((l, Arg (ty, Sort.value)) :: args) ty_fun
+        | Tarrow ((l,_marg,_mret),_,ty_fun,_) when is_position l ->
+            let arg = src_pos (Location.ghostify sarg.pexp_loc) [] env in
+            make_args ((l, Arg (arg, Sort.value)) :: args) ty_fun
         | Tarrow ((l,_,_),_,ty_res',_) when l = Nolabel || !Clflags.classic ->
             List.rev args, ty_fun, no_labels ty_res'
         | Tvar _ ->  List.rev args, ty_fun, false
@@ -6458,7 +6471,7 @@ and type_argument ?explanation ?recarg env (mode : expected_mode) sarg
         (Warnings.Eliminated_optional_arguments
            (List.map (fun (l, _) -> Printtyp.string_of_label l) args));
       if warn then Location.prerr_warning texp.exp_loc
-          (Warnings.Non_principal_labels "eliminated optional argument");
+          (Warnings.Non_principal_labels "eliminated omittable argument");
       (* let-expand to have side effects *)
       let let_pat, let_var = var_pair ~mode:exp_mode "arg" texp.exp_type in
       re { texp with exp_type = ty_fun;
@@ -6549,9 +6562,16 @@ and type_apply_arg env ~app_loc ~funct ~index ~position ~partial_app (lbl, arg)
         end
       in
       (lbl, Arg (arg, expected_mode.mode, sort_arg))
-  | Arg (Eliminated_optional_arg { ty_arg; sort_arg; _ }) ->
-      let arg = option_none env (instance ty_arg) Location.none in
-      (lbl, Arg (arg, Value_mode.global, sort_arg))
+  | Arg (Eliminated_optional_arg { ty_arg; sort_arg; expected_label; _ }) ->
+      (match expected_label with
+      | Optional _ ->
+          let arg = option_none env (instance ty_arg) Location.none in
+          (lbl, Arg (arg, Value_mode.global, sort_arg))
+      | Position _ ->
+          let arg = src_pos (Location.ghostify app_loc) [] env in
+          (* CR src_pos: Confirm that global value mode is correct *)
+          (lbl, Arg (arg, Value_mode.global, sort_arg))
+      | Labelled _ | Nolabel -> assert false)
   | Omitted _ as arg -> (lbl, arg)
 
 and type_application env app_loc expected_mode pm
@@ -6592,7 +6612,7 @@ and type_application env app_loc expected_mode pm
         begin
           let ls, tvar = list_labels env funct.exp_type in
           not tvar &&
-          let labels = List.filter (fun l -> not (is_optional l)) ls in
+          let labels = List.filter (fun l -> not (is_omittable l)) ls in
           List.length labels = List.length sargs &&
           List.for_all (fun (l,_) -> l = Parsetree.Nolabel) sargs &&
           List.exists (fun l -> l <> Nolabel) labels &&

ocaml/utils/warnings.ml

@@ -107,6 +107,7 @@ type t =
   | Missing_mli                             (* 70 *)
   | Unused_tmc_attribute                    (* 71 *)
   | Tmc_breaks_tailcall                     (* 72 *)
+  | Unerasable_position_argument            (* 189 *)
   | Probe_name_too_long of string           (* 190 *)
   | Misplaced_assume_attribute of string    (* 198 *)
   | Unchecked_property_attribute of string  (* 199 *)
@@ -192,6 +193,7 @@ let number = function
   | Missing_mli -> 70
   | Unused_tmc_attribute -> 71
   | Tmc_breaks_tailcall -> 72
+  | Unerasable_position_argument -> 189
   | Probe_name_too_long _ -> 190
   | Misplaced_assume_attribute _  -> 198
   | Unchecked_property_attribute _ -> 199
@@ -452,6 +454,9 @@ let descriptions = [
     names = ["tmc-breaks-tailcall"];
     description = "A tail call is turned into a non-tail call \
                    by the @tail_mod_cons transformation." };
+  { number = 189;
+    names = ["unerasable-position-argument"];
+    description = "Unerasable position argument." };
   { number = 190;
     names = ["probe-name-too-long"];
     description = "Probe name must be at most 100 characters long." };
@@ -1062,6 +1067,7 @@ let message = function
        Please either mark the called function with the [@tail_mod_cons]\n\
        attribute, or mark this call with the [@tailcall false] attribute\n\
        to make its non-tailness explicit."
+  | Unerasable_position_argument -> "this position argument cannot be erased."
   | Probe_name_too_long name ->
       Printf.sprintf
         "This probe name is too long: `%s'. \

ocaml/utils/warnings.mli

@@ -110,6 +110,7 @@ type t =
   | Unused_tmc_attribute                    (* 71 *)
   | Tmc_breaks_tailcall                     (* 72 *)
 (* Flambda_backend specific warnings: numbers should go down from 199 *)
+  | Unerasable_position_argument            (* 189 *)
   | Probe_name_too_long of string           (* 190 *)
   | Misplaced_assume_attribute of string    (* 198 *)
   | Unchecked_property_attribute of string  (* 199 *)