Apply position arguments when expected type is nothing, refactor creating src_pos exprs

Author: vivianyyd

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

@@ -13,6 +13,11 @@ let _ = f ();;
 {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 :
@@ -23,8 +28,8 @@ val g :
 let _ = g () ;;
 [%%expect{|
 - : lexing_position * lexing_position =
-({pos_fname = ""; pos_lnum = 1; pos_bol = 452; pos_cnum = 460},
- {pos_fname = ""; pos_lnum = 1; pos_bol = 452; pos_cnum = 460})
+({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
@@ -44,6 +49,23 @@ 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 = 1022; pos_cnum = 1030},
+  ({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}
+|}]

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
@@ -5720,12 +5728,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))
 
@@ -6353,7 +6356,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
@@ -6372,7 +6375,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
-        (* TODO vding: Add a case for Position arguments? *)
+        | 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
@@ -6558,15 +6563,9 @@ and type_apply_arg env ~app_loc ~funct ~index ~position ~partial_app (lbl, arg)
           let arg = option_none env (instance ty_arg) Location.none in
           (lbl, Arg (arg, Value_mode.global, sort_arg))
       | Position _ ->
-          let arg = {
-            exp_desc = Texp_src_pos;
-            exp_loc = Location.ghostify app_loc;
-            exp_extra = [];
-            exp_type = instance Predef.type_lexing_position;
-            exp_attributes = [];
-            exp_env = env }
-            (* CR src_pos: Confirm that global value mode is correct *)
-          in (lbl, Arg (arg, Value_mode.global, sort_arg))
+          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)