flambda-backend: Implicit source positions (#2401)

* Start of implicit-source-positions Expand [%src_pos] to hard-coded record (#1565) * Update codeowners * Revert "Update codeowners" This reverts commit 313cb2d. * Start * backup * Hacky checkpoint with hard-coded record * Rename test * Shadowing works as intended * Simpler test case * Fix label layouts * Change name to lexing_position, fix record layout, add to shadowing test * Add to test * Formatting * Tests, fix predef lexing_position layout, add CR for untypeast shadowing * Fix test * Fix untracked file * Revert "Fix untracked file" This reverts commit 2a18a6a. * reformat * Bootstrap, with predef lexing_position --------- Co-authored-by: Richard Eisenberg <reisenberg@janestreet.com> Separate `arg_label`s for Parse and Typed trees (#1589) * src_pos in fn decls and defns * Revert is_optional modifications for now * src_pos shouldn't work in arbitrary places * Tidy code * Whitespace * Add test * Comment on documentation * Whitespace * more whitespace * Amend test to use Position * Correctly print [%src_pos] rather than lexing_position and fix corresponding test * Store hard-coded string in variable * Separate parsed and typed labels * Delete fn_decl_and_defn.ml * Delete invalid_usages.ml * Minimize diffs in PR * Minimize diffs in PR * Update named_function.ml for less diffs * Clean up * Put arg_label in Outcome tree * Revert "Put arg_label in Outcome tree" This reverts commit cd5ace5. * is_optional for Parsetree arg_labels * Restore Asttypes.arg_label, re-export arg_label from Types * Document distinction between arg_labels * Fix whitespace * Add todo comment Add `arg_label` to `Otyp_arrow` (#1644) * Put arg_label in Outcome tree * Add comment for Outcometree.arg_label `[%src_pos]` in fn decls and defns (#1579) * src_pos in fn decls and defns * Revert is_optional modifications for now * src_pos shouldn't work in arbitrary places * Tidy code * Whitespace * Add test * Comment on documentation * Whitespace * more whitespace * Amend test to use Position * Correctly print [%src_pos] rather than lexing_position and fix corresponding test * Store hard-coded string in variable * Hacky outcometree printing without creating nontrivial node * Update documentation for Position labels * Update tests * Fix erroneously printing lexing_position for Position arguments * Clean up code * Reconstruct constraint for Position arguments in Untypeast * Update tests * Move comments around * Slightly prettify * Use Location.none in Untypeast reconstructed extensions * Add Ttyp_src_pos to Typedtree * Add CR * Comments * Clean up code * Update comment in printtyp.ml * Add documentation for Ttyp_src_pos, remove extraneous comments * *synonyms.ml * src_pos in fn decls and defns * Revert is_optional modifications for now * src_pos shouldn't work in arbitrary places * Tidy code * Whitespace * Add test * Comment on documentation * Whitespace * Correctly print [%src_pos] rather than lexing_position and fix corresponding test * Store hard-coded string in variable * Hacky outcometree printing without creating nontrivial node * Update documentation for Position labels * Update tests * Fix erroneously printing lexing_position for Position arguments * Clean up code * Reconstruct constraint for Position arguments in Untypeast * Update tests * Move comments around * Slightly prettify * Use Location.none in Untypeast reconstructed extensions * Add Ttyp_src_pos to Typedtree * Add CR * Comments * Clean up code * Add documentation for Ttyp_src_pos, remove extraneous comments * *synonyms.ml * Merge cleanup * Add label to Octy_arrow * Rename function * transl_label checks for Position * Pass None to transl_label for classes * Add comment * Delete comment * Consider Position when approximating type * Add tests for application, recursion * Error messages mention Position * Prettify * Comments * Rename function * Add comment * Remove extraneous calls to label translation * Test type-based disambiguation * Add comment for fn app labels * Add commuting tests * Remove duplicated src_pos match logic * Reduce instances of src_pos string * src_pos in fn decls and defns * src_pos shouldn't work in arbitrary places * Whitespace * Correctly print [%src_pos] rather than lexing_position and fix corresponding test * Store hard-coded string in variable * Hacky outcometree printing without creating nontrivial node * Clean up code * Slightly prettify * Add CR * Clean up code * Update comment in printtyp.ml * Merge cleanup * Add label to Octy_arrow * Rename function * transl_label checks for Position * Pass None to transl_label for classes * Add comment * Delete comment * Consider Position when approximating type * Add tests for application, recursion * Error messages mention Position * Prettify * Comments * Rename function * Add comment * Remove extraneous calls to label translation * Test type-based disambiguation * Add comment for fn app labels * Add commuting tests * Remove duplicated src_pos match logic * Reduce instances of src_pos string * Make things is_optional again * Add commuting tests * Add transl_label_from_pat * Whitespace * Parenthesize src_pos in error message * Fix test Create `Lexing.position` values when `[%src_pos]` in expressions (#1661) * Everything * checkpoint Construct lambda for src_pos directly * Revert now unneeded changes to predef * Clean up comments, whitespace Implicitly supply source position arguments (#1671) * Everything * Apply position arguments when expected type is nothing, refactor creating src_pos exprs * Add warning instead of modifying existing one * Fix test * Move test * Resolved comments Clearer classic mode label equivalence checks (#1692) * Everything * Apply position arguments when expected type is nothing, refactor creating src_pos exprs * Add warning instead of modifying existing one * Fix test * Move test * Resolved comments * Classic mode equivalence check * Refactor * Implicit source position merge conflicts (#2275) * Implicit Source Positions Conflict resolution This feature solely fixes merge conflicts that the implicit source positions project had after not having been rebased since the summer. Sadly, I mistakenly committed a new test! I meant to do it on a different branch, but I accidentally committed some more changes after that making it trickier to split... Please let me know if I should only keep this feature do "merge conflict resolution". Thanks! Testing ------- - I ran `make test`, and it passes. - `make install` works, I migrated bonsai to start using this and it works! - Added test on let operators. - Sadly it doesn't quite work, but I think it would be cool if it did work as it would allow codebases that use let+ and let* to get source code locations! I am unsure about its sound-ness though and left CR src_pos'es/question CR's. Please let me know if there is other additional testing/ci I should perform. Thanks! I also performed additional cleanup in this feature from self-questions I had during the merge. Please let me know if there are any changes I should perform. Thanks! * More cleanup after self-review * Made CI on Github pass - CI seems to run `make ci` instead of just `make test`. I've fixed more `make ci` changes, although not all, pushing to let ci run in case the current "compiler-libs.common" being missing is due to a misconfiguration on my environment/if it also fails on the github ci being missing is due to a misconfiguration on my environment/if it also fails on the github ci. - Performed a bootstrap - Fixed chamelon - Additionally turned my questions on let operator support into CR src_pos: * Removed empty file added accidentally * Updated let_operator support comment * Widened question on chamelon compatibility * Implicit source positions object system support (#2307) * Implicit Source Positions Conflict resolution This feature solely fixes merge conflicts that the implicit source positions project had after not having been rebased since the summer. Sadly, I mistakenly committed a new test! I meant to do it on a different branch, but I accidentally committed some more changes after that making it trickier to split... Please let me know if I should only keep this feature do "merge conflict resolution". Thanks! Testing ------- - I ran `make test`, and it passes. - `make install` works, I migrated bonsai to start using this and it works! - Added test on let operators. - Sadly it doesn't quite work, but I think it would be cool if it did work as it would allow codebases that use let+ and let* to get source code locations! I am unsure about its sound-ness though and left CR src_pos'es/question CR's. Please let me know if there is other additional testing/ci I should perform. Thanks! I also performed additional cleanup in this feature from self-questions I had during the merge. Please let me know if there are any changes I should perform. Thanks! * Moves changes from original class-type support branch into a rebased branch * Removed lingering merge conflict markers * More tests + manually moved a commit from the original class type branch - For some reason I originally missed a commit that typed the argument on classes from the original branch. This feature also grabs the tests. Some of my questions revolving `Principal` are no longer needed as they seem to have disappeared! I suspect that `make ci` now passing in the parent feature is partly/transitively responsible somehow for `Principal` now no longer showing up. * Fixed incorrect merging of invalid_usages.ml * Removes weird whitespace observed after self-review * More tests! Found out that application on an inheritance call is unhandled! * Explicit passing positional argument in a pcl_apply works, erasure still does not. * Added Pcl_apply support * More cleanup + removed a question cr from the parent feature. * More tests. Found another bug! Class type arrows seeem to be left untranslated... * Fixed type annotation bug + added more tests * Removed duplicated test * Added more tests + fixed weird whitespace * Added question on the two class system environments (val_env vs. met_env) * Deduplicated more code after self-review * minor whitespace change * Removed resolved question CR and addressed new CRs * Implicit source positions directory locations (#2346) * Implicit Source Positions Conflict resolution This feature solely fixes merge conflicts that the implicit source positions project had after not having been rebased since the summer. Sadly, I mistakenly committed a new test! I meant to do it on a different branch, but I accidentally committed some more changes after that making it trickier to split... Please let me know if I should only keep this feature do "merge conflict resolution". Thanks! Testing ------- - I ran `make test`, and it passes. - `make install` works, I migrated bonsai to start using this and it works! - Added test on let operators. - Sadly it doesn't quite work, but I think it would be cool if it did work as it would allow codebases that use let+ and let* to get source code locations! I am unsure about its sound-ness though and left CR src_pos'es/question CR's. Please let me know if there is other additional testing/ci I should perform. Thanks! I also performed additional cleanup in this feature from self-questions I had during the merge. Please let me know if there are any changes I should perform. Thanks! * More cleanup after self-review * Made CI on Github pass - CI seems to run `make ci` instead of just `make test`. I've fixed more `make ci` changes, although not all, pushing to let ci run in case the current "compiler-libs.common" being missing is due to a misconfiguration on my environment/if it also fails on the github ci being missing is due to a misconfiguration on my environment/if it also fails on the github ci. - Performed a bootstrap - Fixed chamelon - Additionally turned my questions on let operator support into CR src_pos: * Removed empty file added accidentally * Updated let_operator support comment * Widened question on chamelon compatibility * Moves changes from original class-type support branch into a rebased branch * Created branch with working changes for directory positions. * Added a test sanity checking being able to pass in the flag. * Changed test to properly test that the right basename is supplied * Removed merge conflict markers upon self review. * Removed lingering merge artifacts upon self review * Renamed flag from -dir to -directory * Fix typo * Removed directory flag from ocamldoc options * [Implicit Source Positions] - Better Error Messages (#2364) * Rename src_pos -> call_pos Also left some self notes regarding the remaining CR src_pos * Improved error messages for %call_pos * Addressed a CR src_pos and removed an already addressed CR src_pos * Cleanup after self-review * Updated missing rename after self-review * Removed addressed c r questions * Fixed merge conflicts. `make ci` passes locally * bootstrap --------- Co-authored-by: jose r <45022810+Enoumy@users.noreply.github.com> Co-authored-by: enoumy <enoumy@gmail.com>
ocaml-flambda · Mar 28, 2024 · f025246 · f025246
1 parent 22c805d
commit f025246
Show file tree

Hide file tree

Showing 63 changed files with 1,417 additions and 163 deletions.
diff --git a/boot/menhir/parser.ml b/boot/menhir/parser.ml
diff --git a/boot/ocamlc b/boot/ocamlc
diff --git a/boot/ocamllex b/boot/ocamllex
diff --git a/driver/main_args.ml b/driver/main_args.ml
@@ -335,6 +335,9 @@ let mk_app_funct f =
 let mk_no_app_funct f =
   "-no-app-funct", Arg.Unit f, " Deactivate applicative functors"
 
+let mk_directory f =
+  "-directory", Arg.String f, " Directory to use for debug reporting like source code location reporting"
+
 let mk_no_check_prims f =
   "-no-check-prims", Arg.Unit f, " Do not check runtime for primitives"
 
@@ -875,6 +878,7 @@ module type Common_options = sig
   val _no_alias_deps : unit -> unit
   val _app_funct : unit -> unit
   val _no_app_funct : unit -> unit
+  val _directory : string -> unit
   val _disable_all_extensions : unit -> unit
   val _only_erasable_extensions : unit -> unit
   val _extension : string -> unit
@@ -1179,6 +1183,7 @@ struct
     mk_no_alias_deps F._no_alias_deps;
     mk_app_funct F._app_funct;
     mk_no_app_funct F._no_app_funct;
+    mk_directory F._directory;
     mk_no_check_prims F._no_check_prims;
     mk_noassert F._noassert;
     mk_noautolink_byt F._noautolink;
@@ -1271,6 +1276,7 @@ struct
     mk_no_alias_deps F._no_alias_deps;
     mk_app_funct F._app_funct;
     mk_no_app_funct F._no_app_funct;
+    mk_directory F._directory;
     mk_disable_all_extensions F._disable_all_extensions;
     mk_only_erasable_extensions F._only_erasable_extensions;
     mk_extension F._extension;
@@ -1402,6 +1408,7 @@ struct
     mk_linscan F._linscan;
     mk_app_funct F._app_funct;
     mk_no_app_funct F._no_app_funct;
+    mk_directory F._directory;
     mk_no_float_const_prop F._no_float_const_prop;
     mk_noassert F._noassert;
     mk_noautolink_opt F._noautolink;
@@ -1541,6 +1548,7 @@ module Make_opttop_options (F : Opttop_options) = struct
     mk_linscan F._linscan;
     mk_app_funct F._app_funct;
     mk_no_app_funct F._no_app_funct;
+    mk_directory F._directory;
     mk_disable_all_extensions F._disable_all_extensions;
     mk_only_erasable_extensions F._only_erasable_extensions;
     mk_extension F._extension;
@@ -1745,6 +1753,7 @@ module Default = struct
     let _no_absname = clear Clflags.absname
     let _no_alias_deps = set transparent_modules
     let _no_app_funct = clear applicative_functors
+    let _directory d = Clflags.directory := Some d 
     let _no_principal = clear principal
     let _no_rectypes = clear recursive_types
     let _no_strict_formats = clear strict_formats

diff --git a/driver/main_args.mli b/driver/main_args.mli
@@ -27,6 +27,7 @@ module type Common_options = sig
   val _no_alias_deps : unit -> unit
   val _app_funct : unit -> unit
   val _no_app_funct : unit -> unit
+  val _directory : string -> unit
   val _disable_all_extensions : unit -> unit
   val _only_erasable_extensions : unit -> unit
   val _extension : string -> unit

diff --git a/lambda/translattribute.ml b/lambda/translattribute.ml
@@ -126,7 +126,7 @@ let get_ids_from_exp exp =
    | { pexp_desc = Pexp_apply (exp, args) } ->
      get_id_from_exp exp ::
      List.map (function
-       | (Asttypes.Nolabel, arg) -> get_id_from_exp arg
+       | (Nolabel, arg) -> get_id_from_exp arg
        | (_, _) -> Result.Error ())
        args
    | _ -> [get_id_from_exp exp])

diff --git a/lambda/translcore.ml b/lambda/translcore.ml
@@ -1044,6 +1044,23 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
     let l = transl_exp ~scopes sort e in
     if Config.stack_allocation then Lexclave l
     else l
+  | Texp_src_pos ->
+      let pos = e.exp_loc.loc_start in
+      let pos =
+        match !Clflags.directory with
+        | None -> pos
+        | Some directory ->
+          let pos_fname = directory ^ "/" ^ pos.pos_fname in
+          { pos with pos_fname }
+      in
+      let cl =
+        [ Const_base (Const_string (pos.pos_fname, e.exp_loc, None))
+        ; Const_base (Const_int pos.pos_lnum)
+        ; Const_base (Const_int pos.pos_bol)
+        ; Const_base (Const_int pos.pos_cnum)
+        ]
+      in
+      Lconst(Const_block(0, cl))
 
 and pure_module m =
   match m.mod_desc with

diff --git a/ocamldoc/odoc_info.mli b/ocamldoc/odoc_info.mli
@@ -797,11 +797,11 @@ val create_index_lists : 'a list -> ('a -> string) -> 'a list list
 val remove_option : Types.type_expr -> Types.type_expr
 
 (** Return [true] if the given label is optional.*)
-val is_optional : Asttypes.arg_label -> bool
+val is_optional : Types.arg_label -> bool
 
 (** Return the label name for the given label,
    i.e. removes the beginning '?' if present.*)
-val label_name : Asttypes.arg_label -> string
+val label_name : Types.arg_label -> string
 
 (** Return the given name where the module name or
    part of it was removed, according to the list of modules

diff --git a/ocamldoc/odoc_misc.mli b/ocamldoc/odoc_misc.mli
@@ -115,8 +115,8 @@ val search_string_backward : pat: string -> s: string -> int
 val remove_option : Types.type_expr -> Types.type_expr
 
 (** Return [true] if the given label is optional.*)
-val is_optional : Asttypes.arg_label -> bool
+val is_optional : Types.arg_label -> bool
 
 (** Return the label name for the given label,
    i.e. removes the beginning '?' if present.*)
-val label_name : Asttypes.arg_label -> string
+val label_name : Types.arg_label -> string
diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml
@@ -1847,10 +1847,10 @@ module Analyser =
           in
           ([], Class_structure (inher_l, ele))
 
-      | (Parsetree.Pcty_arrow (parse_label, _, pclass_type), Types.Cty_arrow (label, type_expr, class_type)) ->
+      | (Parsetree.Pcty_arrow (parse_label, type_, pclass_type), Types.Cty_arrow (label, type_expr, class_type)) ->
           (* label = string. In signature, there is no parameter names inside tuples *)
           (* if label = "", no label . Here we have the information to determine if a label is explicit or not. *)
-          if parse_label = label then
+          if (Typetexp.transl_label parse_label (Some type_)) = label then
             (
              let new_param = Simple_name
                  {

diff --git a/ocamldoc/odoc_str.ml b/ocamldoc/odoc_str.ml
@@ -135,7 +135,7 @@ let string_of_class_params c =
         Printf.bprintf b "%s%s%s%s -> "
           (
            match label with
-             Asttypes.Nolabel -> ""
+             Types.Nolabel -> ""
            | s -> Printtyp.string_of_label s ^":"
           )
           (if parent then "(" else "")

diff --git a/ocamldoc/odoc_value.ml b/ocamldoc/odoc_value.ml
@@ -88,10 +88,9 @@ let dummy_parameter_list typ =
   let rec iter (label, t) =
     match Types.get_desc t with
     | Types.Ttuple l ->
-        let open Asttypes in
-        if label = Nolabel then
+        if label = Types.Nolabel then
           Odoc_parameter.Tuple
-            (List.map (fun t2 -> iter (Nolabel, t2)) (List.map snd l), t)
+            (List.map (fun t2 -> iter (Types.Nolabel, t2)) (List.map snd l), t)
         else
           (* if there is a label, then we don't want to decompose the tuple *)
           Odoc_parameter.Simple_name

diff --git a/parsing/asttypes.mli b/parsing/asttypes.mli
@@ -52,6 +52,7 @@ type closed_flag = Closed | Open
 
 type label = string
 
+(** This is used only in the Parsetree. *)
 type arg_label =
     Nolabel
   | Labelled of string (** [label:T -> ...] *)

diff --git a/parsing/builtin_attributes.ml b/parsing/builtin_attributes.ml
@@ -219,6 +219,8 @@ let error_of_extension ext =
       | _ ->
           Location.errorf ~loc "Invalid syntax for extension '%s'." txt
       end
+  | ({txt = "call_pos"; loc}, _) ->
+      Location.errorf ~loc "[%%call_pos] can only exist as the type of a labelled argument"
   | ({txt; loc}, _) ->
       Location.errorf ~loc "Uninterpreted extension '%s'." txt
 

diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
@@ -90,11 +90,11 @@ and core_type_desc =
   | Ptyp_arrow of arg_label * core_type * core_type
       (** [Ptyp_arrow(lbl, T1, T2)] represents:
             - [T1 -> T2]    when [lbl] is
-                                     {{!Asttypes.arg_label.Nolabel}[Nolabel]},
+                                     {{!arg_label.Nolabel}[Nolabel]},
             - [~l:T1 -> T2] when [lbl] is
-                                     {{!Asttypes.arg_label.Labelled}[Labelled]},
+                                     {{!arg_label.Labelled}[Labelled]},
             - [?l:T1 -> T2] when [lbl] is
-                                     {{!Asttypes.arg_label.Optional}[Optional]}.
+                                     {{!arg_label.Optional}[Optional]}.
          *)
   | Ptyp_tuple of core_type list
       (** [Ptyp_tuple([T1 ; ... ; Tn])]
@@ -168,6 +168,11 @@ and core_type_desc =
   | Ptyp_package of package_type  (** [(module S)]. *)
   | Ptyp_extension of extension  (** [[%id]]. *)
 
+and arg_label = Asttypes.arg_label =
+    Nolabel
+  | Labelled of string
+  | Optional of string
+
 and package_type = Longident.t loc * (Longident.t loc * core_type) list
 (** As {!package_type} typed values:
          - [(S, [])] represents [(module S)],
@@ -314,34 +319,37 @@ and expression_desc =
   | Pexp_fun of arg_label * expression option * pattern * expression
       (** [Pexp_fun(lbl, exp0, P, E1)] represents:
             - [fun P -> E1]
-                      when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]}
+                      when [lbl] is {{!arg_label.Nolabel}[Nolabel]}
                        and [exp0] is [None]
             - [fun ~l:P -> E1]
-                      when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]}
+                      when [lbl] is {{!arg_label.Labelled}[Labelled l]}
                        and [exp0] is [None]
             - [fun ?l:P -> E1]
-                      when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]}
+                      when [lbl] is {{!arg_label.Optional}[Optional l]}
                        and [exp0] is [None]
             - [fun ?l:(P = E0) -> E1]
-                      when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]}
+                      when [lbl] is {{!arg_label.Optional}[Optional l]}
                        and [exp0] is [Some E0]
 
            Notes:
            - If [E0] is provided, only
-             {{!Asttypes.arg_label.Optional}[Optional]} is allowed.
+             {{!arg_label.Optional}[Optional]} is allowed.
            - [fun P1 P2 .. Pn -> E1] is represented as nested
              {{!expression_desc.Pexp_fun}[Pexp_fun]}.
            - [let f P = E] is represented using
              {{!expression_desc.Pexp_fun}[Pexp_fun]}.
+           - While Position arguments ([lbl:[%call_pos] -> ...]) are parsed as
+             {{!Asttypes.arg_label.Labelled}[Labelled l]}, they are converted to
+             {{!Types.arg_label.Position}[Position l]} arguments for type-checking.
          *)
   | Pexp_apply of expression * (arg_label * expression) list
       (** [Pexp_apply(E0, [(l1, E1) ; ... ; (ln, En)])]
             represents [E0 ~l1:E1 ... ~ln:En]
 
             [li] can be
-              {{!Asttypes.arg_label.Nolabel}[Nolabel]}   (non labeled argument),
-              {{!Asttypes.arg_label.Labelled}[Labelled]} (labelled arguments) or
-              {{!Asttypes.arg_label.Optional}[Optional]} (optional argument).
+              {{!arg_label.Nolabel}[Nolabel]}   (non labeled argument),
+              {{!arg_label.Labelled}[Labelled]} (labelled arguments) or
+              {{!arg_label.Optional}[Optional]} (optional argument).
 
            Invariant: [n > 0]
          *)
@@ -636,11 +644,11 @@ and class_type_desc =
   | Pcty_arrow of arg_label * core_type * class_type
       (** [Pcty_arrow(lbl, T, CT)] represents:
             - [T -> CT]
-                     when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]},
+                     when [lbl] is {{!arg_label.Nolabel}[Nolabel]},
             - [~l:T -> CT]
-                     when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]},
+                     when [lbl] is {{!arg_label.Labelled}[Labelled l]},
             - [?l:T -> CT]
-                     when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]}.
+                     when [lbl] is {{!arg_label.Optional}[Optional l]}.
          *)
   | Pcty_extension of extension  (** [%id] *)
   | Pcty_open of open_description * class_type  (** [let open M in CT] *)
@@ -713,16 +721,16 @@ and class_expr_desc =
   | Pcl_fun of arg_label * expression option * pattern * class_expr
       (** [Pcl_fun(lbl, exp0, P, CE)] represents:
             - [fun P -> CE]
-                     when [lbl]  is {{!Asttypes.arg_label.Nolabel}[Nolabel]}
+                     when [lbl]  is {{!arg_label.Nolabel}[Nolabel]}
                       and [exp0] is [None],
             - [fun ~l:P -> CE]
-                     when [lbl]  is {{!Asttypes.arg_label.Labelled}[Labelled l]}
+                     when [lbl]  is {{!arg_label.Labelled}[Labelled l]}
                       and [exp0] is [None],
             - [fun ?l:P -> CE]
-                     when [lbl]  is {{!Asttypes.arg_label.Optional}[Optional l]}
+                     when [lbl]  is {{!arg_label.Optional}[Optional l]}
                       and [exp0] is [None],
             - [fun ?l:(P = E0) -> CE]
-                     when [lbl]  is {{!Asttypes.arg_label.Optional}[Optional l]}
+                     when [lbl]  is {{!arg_label.Optional}[Optional l]}
                       and [exp0] is [Some E0].
         *)
   | Pcl_apply of class_expr * (arg_label * expression) list

diff --git a/stdlib/lexing.ml b/stdlib/lexing.ml
@@ -20,7 +20,7 @@ open! Stdlib
 
 (* The run-time library for lexers generated by camllex *)
 
-type position = {
+type position = lexing_position = {
   pos_fname : string;
   pos_lnum : int;
   pos_bol : int;

diff --git a/stdlib/lexing.mli b/stdlib/lexing.mli
@@ -20,12 +20,13 @@ open! Stdlib
 
 (** {1 Positions} *)
 
-type position = {
+type position = lexing_position = {
   pos_fname : string;
   pos_lnum : int;
   pos_bol : int;
   pos_cnum : int;
 }
+
 (** A value of type [position] describes a point in a source file.
    [pos_fname] is the file name; [pos_lnum] is the line number;
    [pos_bol] is the offset of the beginning of the line (number

diff --git a/testsuite/tests/ppx-empty-cases/test.compilers.reference b/testsuite/tests/ppx-empty-cases/test.compilers.reference
@@ -3,35 +3,35 @@
     (empty_cases_returning_string/269 =
        (function {nlocal = 0} param/271
          (raise
-           (makeblock 0 (getpredef Match_failure/30!!) [0: "test.ml" 28 50])))
+           (makeblock 0 (getpredef Match_failure/31!!) [0: "test.ml" 28 50])))
      empty_cases_returning_float64/272 =
        (function {nlocal = 0} param/274 : unboxed_float
          (raise
-           (makeblock 0 (getpredef Match_failure/30!!) [0: "test.ml" 29 50])))
+           (makeblock 0 (getpredef Match_failure/31!!) [0: "test.ml" 29 50])))
      empty_cases_accepting_string/275 =
        (function {nlocal = 0} param/277
          (raise
-           (makeblock 0 (getpredef Match_failure/30!!) [0: "test.ml" 30 50])))
+           (makeblock 0 (getpredef Match_failure/31!!) [0: "test.ml" 30 50])))
      empty_cases_accepting_float64/278 =
        (function {nlocal = 0} param/280[unboxed_float]
          (raise
-           (makeblock 0 (getpredef Match_failure/30!!) [0: "test.ml" 31 50])))
+           (makeblock 0 (getpredef Match_failure/31!!) [0: "test.ml" 31 50])))
      non_empty_cases_returning_string/281 =
        (function {nlocal = 0} param/283
          (raise
-           (makeblock 0 (getpredef Assert_failure/40!!) [0: "test.ml" 32 68])))
+           (makeblock 0 (getpredef Assert_failure/41!!) [0: "test.ml" 32 68])))
      non_empty_cases_returning_float64/284 =
        (function {nlocal = 0} param/286 : unboxed_float
          (raise
-           (makeblock 0 (getpredef Assert_failure/40!!) [0: "test.ml" 33 68])))
+           (makeblock 0 (getpredef Assert_failure/41!!) [0: "test.ml" 33 68])))
      non_empty_cases_accepting_string/287 =
        (function {nlocal = 0} param/289
          (raise
-           (makeblock 0 (getpredef Assert_failure/40!!) [0: "test.ml" 34 68])))
+           (makeblock 0 (getpredef Assert_failure/41!!) [0: "test.ml" 34 68])))
      non_empty_cases_accepting_float64/290 =
        (function {nlocal = 0} param/292[unboxed_float]
          (raise
-           (makeblock 0 (getpredef Assert_failure/40!!) [0: "test.ml" 35 68]))))
+           (makeblock 0 (getpredef Assert_failure/41!!) [0: "test.ml" 35 68]))))
     (makeblock 0 empty_cases_returning_string/269
       empty_cases_returning_float64/272 empty_cases_accepting_string/275
       empty_cases_accepting_float64/278 non_empty_cases_returning_string/281