Cleanup Outcometree and separated arg_labels

ocaml/parsing/parsetree.mli

@@ -170,8 +170,8 @@ and core_type_desc =
 
 and arg_label = Asttypes.arg_label =
     Nolabel
-  | Labelled of string (** [label:T -> ...] *)
-  | Optional of string (** [?label:T -> ...] *)
+  | Labelled of string
+  | Optional of string
 
 and package_type = Longident.t loc * (Longident.t loc * core_type) list
 (** As {!package_type} typed values:
@@ -338,6 +338,9 @@ and expression_desc =
              {{!expression_desc.Pexp_fun}[Pexp_fun]}.
            - [let f P = E] is represented using
              {{!expression_desc.Pexp_fun}[Pexp_fun]}.
+           -  While Position arguments are parsed as
+              {{!Asttypes.arg_label.Labelled}[Labelled l]}, they are converted to
+              {{!Asttypes.arg_label.Position}[Position l]} arguments for type-checking.
          *)
   | Pexp_apply of expression * (arg_label * expression) list
       (** [Pexp_apply(E0, [(l1, E1) ; ... ; (ln, En)])]

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

@@ -0,0 +1,36 @@
+(* TEST
+   * expect
+*)
+
+type t = src_pos:[%src_pos] -> unit -> unit
+
+[%%expect {|
+type t = src_pos:[%src_pos] -> unit -> unit
+|}]
+
+let f : t = fun ~(src_pos:[%src_pos]) () -> ()
+
+[%%expect{|
+val f : t = <fun>
+|}]
+
+let g ~(src_pos:[%src_pos]) () = ()
+
+[%%expect{|
+val g : src_pos:[%src_pos] -> unit -> unit = <fun>
+|}]
+
+let apply (f : t) = f ~src_pos:Lexing.dummy_pos () ;;
+[%%expect {|
+val apply : t -> unit = <fun>
+|}]
+
+let _ = apply f ;;
+[%%expect{|
+- : unit = ()
+|}]
+
+let _ = apply g ;;
+[%%expect{|
+- : unit = ()
+|}]

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

@@ -0,0 +1,51 @@
+(* TEST
+   * expect
+*)
+
+type t = [%src_pos]
+[%%expect {|
+Line 1, characters 11-18:
+1 | type t = [%src_pos]
+               ^^^^^^^
+Error: Uninterpreted extension 'src_pos'.
+|}]
+(* CR src_pos: Improve this error message to notify that [%src_pos] may only
+   be used in arguments *)
+
+type t = unit -> unit -> [%src_pos]
+[%%expect {|
+Line 1, characters 27-34:
+1 | type t = unit -> unit -> [%src_pos]
+                               ^^^^^^^
+Error: Uninterpreted extension 'src_pos'.
+|}]
+
+let f ~(src_pos:[%src_pos]) () : [%src_pos] = src_pos
+
+[%%expect{|
+Line 1, characters 35-42:
+1 | let f ~(src_pos:[%src_pos]) () : [%src_pos] = src_pos
+                                       ^^^^^^^
+Error: Uninterpreted extension 'src_pos'.
+|}]
+
+let apply f = f ~src_pos:Lexing.dummy_pos () ;;
+[%%expect {|
+val apply : (src_pos:Lexing.position -> unit -> 'a) -> 'a = <fun>
+|}]
+
+let g = fun ~(src_pos:[%src_pos]) () -> ()
+
+[%%expect{|
+val g : src_pos:[%src_pos] -> unit -> unit = <fun>
+|}]
+
+let _ = apply g ;;
+[%%expect{|
+Line 1, characters 14-15:
+1 | let _ = apply g ;;
+                  ^
+Error: This expression has type src_pos:[%src_pos] -> unit -> unit
+       but an expression was expected of type
+         src_pos:Lexing.position -> unit -> 'a
+|}]

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

@@ -10,18 +10,18 @@ type lexing_position = int
 |}]
 
 (* src_pos works *)
-let f ~(src_pos:[%src_pos]) = ();;
+let f ~(src_pos:[%src_pos]) () = ();;
 [%%expect{|
-val f : src_pos:lexing_position/2 -> unit = <fun>
+val f : src_pos:[%src_pos] -> unit -> unit = <fun>
 |}]
 
-let _ = f ~src_pos:{pos_fname="hello" ; pos_lnum=1; pos_bol=2; pos_cnum=3} ;;
+let _ = f ~src_pos:Lexing.dummy_pos () ;;
 [%%expect{|
 - : unit = ()
 |}]
 
 (* new type works *)
-let h (x:lexing_position) = x ;;
+let h (x : lexing_position) = x ;;
 [%%expect{|
 val h : lexing_position -> lexing_position = <fun>
 |}]

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

@@ -2,27 +2,39 @@
    * expect
 *)
 
-(* src_pos (lexing_position) and Lexing.position are synonyms *)
-let predef_to_module ~(src_pos:[%src_pos]) : Lexing.position = src_pos ;; 
+(* lexing_position and Lexing.position are synonyms *)
+let x = Lexing.dummy_pos;;
+[%%expect {|
+val x : Lexing.position =
+  {Lexing.pos_fname = ""; pos_lnum = 0; pos_bol = 0; pos_cnum = -1}
+|}]
+
+let y : lexing_position = x;;
+[%%expect {|
+val y : lexing_position =
+  {pos_fname = ""; pos_lnum = 0; pos_bol = 0; pos_cnum = -1}
+|}]
+
+let predef_to_module ~(src_pos:[%src_pos]) () : Lexing.position = src_pos ;;
 [%%expect{|
-val predef_to_module : src_pos:lexing_position -> Lexing.position = <fun>
+val predef_to_module : src_pos:[%src_pos] -> unit -> Lexing.position = <fun>
 |}]
 
-let module_to_predef (src_pos:Lexing.position) : [%src_pos] = src_pos ;; 
+let module_to_predef (src_pos:Lexing.position) : lexing_position = src_pos ;;
 [%%expect{|
 val module_to_predef : Lexing.position -> lexing_position = <fun>
 |}]
 
-let x = predef_to_module ~src_pos:{pos_fname="hello" ; pos_lnum=1; pos_bol=2; pos_cnum=3};;
+let x = predef_to_module ~src_pos:Lexing.dummy_pos ();;
 [%%expect{|
 val x : Lexing.position =
-  {Lexing.pos_fname = "hello"; pos_lnum = 1; pos_bol = 2; pos_cnum = 3}
+  {Lexing.pos_fname = ""; pos_lnum = 0; pos_bol = 0; pos_cnum = -1}
 |}]
 
-let y = module_to_predef {pos_fname="hello" ; pos_lnum=1; pos_bol=2; pos_cnum=3};;
+let y = module_to_predef Lexing.dummy_pos;;
 [%%expect{|
 val y : lexing_position =
-  {pos_fname = "hello"; pos_lnum = 1; pos_bol = 2; pos_cnum = 3}
+  {pos_fname = ""; pos_lnum = 0; pos_bol = 0; pos_cnum = -1}
 |}]
 
 (* Fields accessible from within Lexing module *)

ocaml/typing/btype.ml

@@ -579,14 +579,22 @@ let is_optional_parsetree : Parsetree.arg_label -> bool = function
 
 let is_optional = function Optional _ -> true | _ -> false
 
+let is_position = function Position _ -> true | _ -> false
+
+let is_omittable = function
+  Optional _
+| Position _ -> true
+| Nolabel | Labelled _ -> false
+
 let label_name = function
     Nolabel -> ""
   | Labelled s
-  | Optional s -> s
+  | Optional s
+  | Position s -> s
 
 let prefixed_label_name = function
     Nolabel -> ""
-  | Labelled s -> "~" ^ s
+  | Labelled s | Position s -> "~" ^ s
   | Optional s -> "?" ^ s
 
 let rec extract_label_aux hd l = function

ocaml/typing/btype.mli

@@ -253,6 +253,8 @@ val backtrack: snapshot -> unit
 
 val is_optional_parsetree : Parsetree.arg_label -> bool
 val is_optional : arg_label -> bool
+val is_position : arg_label -> bool
+val is_omittable : arg_label -> bool
 val label_name : arg_label -> label
 
 (* Returns the label name with first character '?' or '~' as appropriate. *)

ocaml/typing/ctype.ml

@@ -3811,6 +3811,8 @@ let filter_arrow env t l ~force_tpoly =
               (Tconstr(Predef.path_option,
                        [newvar2 level (Layout.value ~why:Type_argument)],
                        ref Mnil))
+          else if is_position l then
+            newty2 ~level (Tconstr (Predef.path_lexing_position, [], ref Mnil))
           else
             newvar2 level l_arg
         in

ocaml/typing/oprint.ml

@@ -305,11 +305,16 @@ and print_out_type_1 mode ppf =
   function
   | Otyp_arrow (lab, am, ty1, rm, ty2) ->
       pp_open_box ppf 0;
+      let print_type () = print_out_arg am ppf ty1 in
       (match lab with
-      | Nolabel -> ()
-      | Labelled l -> pp_print_string ppf l; pp_print_char ppf ':'
-      | Optional l -> pp_print_string ppf ("?"^l); pp_print_char ppf ':');
-      print_out_arg am ppf ty1;
+      | Nolabel -> print_type ()
+      | Labelled l ->
+          pp_print_string ppf l; pp_print_char ppf ':'; print_type ()
+      | Position l ->
+          pp_print_string ppf l;
+          pp_print_string ppf ":[%src_pos]"
+      | Optional l ->
+          pp_print_string ppf ("?" ^ l); pp_print_char ppf ':'; print_type ());
       pp_print_string ppf " ->";
       pp_print_space ppf ();
       let mode = join_modes mode am in
@@ -515,8 +520,17 @@ let rec print_out_class_type ppf =
       in
       fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id
   | Octy_arrow (lab, ty, cty) ->
-      fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "")
-        (print_out_type_2 Oam_global) ty print_out_class_type cty
+      let print_type = print_out_type_2 Oam_global in
+      let label, print_type = match lab with
+        | Nolabel -> "", print_type
+        | Labelled l -> l ^ ":", print_type
+        | Position l -> l ^ ":", fun ppf _ -> pp_print_string ppf "[%src_pos]"
+        | Optional l -> "?" ^ l ^ ":", print_type
+      in
+      fprintf ppf "@[%s%a ->@ %a@]"
+        label
+        print_type ty
+        print_out_class_type cty
   | Octy_signature (self_ty, csil) ->
       let pr_param ppf =
         function

ocaml/typing/outcometree.mli

@@ -78,8 +78,9 @@ type out_global =
 (** This definition avoids a cyclic dependency between Outcometree and Types. *)
 type arg_label =
   | Nolabel
-  | Labelled of string (** [label:T -> ...] *)
-  | Optional of string (*** [?label:T -> ...] *)
+  | Labelled of string
+  | Optional of string
+  | Position of string
 
 type out_type =
   | Otyp_abstract
@@ -121,7 +122,7 @@ and out_alloc_mode =
 
 type out_class_type =
   | Octy_constr of out_ident * out_type list
-  | Octy_arrow of string * out_type * out_class_type
+  | Octy_arrow of arg_label * out_type * out_class_type
   | Octy_signature of out_type option * out_class_sig_item list
 and out_class_sig_item =
   | Ocsg_constraint of out_type * out_type

ocaml/typing/printtyp.ml

@@ -508,10 +508,10 @@ let print_name ppf = function
     None -> fprintf ppf "None"
   | Some name -> fprintf ppf "\"%s\"" name
 
-let string_of_label = function
-    Asttypes.Nolabel -> ""
-  | Asttypes.Labelled s -> s
-  | Asttypes.Optional s -> "?"^s
+let string_of_label : Types.arg_label -> string = function
+    Nolabel -> ""
+  | Labelled s | Position s -> s
+  | Optional s -> "?"^s
 
 let visited = ref []
 let rec raw_type ppf ty =
@@ -1098,7 +1098,13 @@ let add_type_to_preparation = prepare_type
 (* Disabled in classic mode when printing an unification error *)
 let print_labels = ref true
 
-let rec tree_of_typexp mode ty =
+let transl_label : Types.arg_label -> Outcometree.arg_label = function
+  | Nolabel -> Nolabel
+  | Labelled l -> Labelled l
+  | Optional l -> Optional l
+  | Position l -> Position l
+
+  let rec tree_of_typexp mode ty =
   let px = proxy ty in
   if List.memq px !printed_aliases && not (List.memq px !delayed) then
    let mark = is_non_gen mode ty in
@@ -1117,11 +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
-            match l with
-            | Nolabel -> Nolabel
-            | Labelled l -> Labelled l
-            | Optional l -> Optional l
+          if !print_labels || is_optional l then transl_label l
           else Nolabel
         in
         let t1 =
@@ -1761,7 +1763,8 @@ 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 string_of_label l else ""
+        if !print_labels || is_optional l then transl_label l
+        else Nolabel
       in
       let tr =
        if is_optional l then

ocaml/typing/printtyped.ml

@@ -153,6 +153,7 @@ let arg_label i ppf = function
   | Nolabel -> line i ppf "Nolabel\n"
   | Optional s -> line i ppf "Optional \"%s\"\n" s
   | Labelled s -> line i ppf "Labelled \"%s\"\n" s
+  | Position s -> line i ppf "Position \"%s\"\n" s
 ;;
 
 let typevars ppf vs =
@@ -244,6 +245,7 @@ let rec core_type i ppf x =
   | Ttyp_package { pack_path = s; pack_fields = l } ->
       line i ppf "Ttyp_package %a\n" fmt_path s;
       list i package_with ppf l;
+  | Ttyp_src_pos -> line i ppf "Ttyp_src_pos\n";
 
 and package_with i ppf (s, t) =
   line i ppf "with type %a\n" fmt_longident s;

ocaml/typing/tast_iterator.ml

@@ -470,6 +470,7 @@ let typ sub {ctyp_desc; ctyp_env; _} =
   | Ttyp_variant (list, _, _) -> List.iter (sub.row_field sub) list
   | Ttyp_poly (_, ct) -> sub.typ sub ct
   | Ttyp_package pack -> sub.package_type sub pack
+  | Ttyp_src_pos -> ()
 
 let class_structure sub {cstr_self; cstr_fields; _} =
   sub.pat sub cstr_self;