New Build_path_prefix_map module interface

The BUILD_PATH_PREFIX_MAP specification tells how to use that
environment variable to achieve reproducible build, i.e. builds of
products that do not leak absolute paths from the build
environment. See
https://reproducible-builds.org/specs/build-path-prefix-map.

However, that specification only describes half of the story.  Let us
call the building of reproducible products the "Build Phase". That is
the phase covered by the existing specification.

Let us defined the "Deployment phase" as the phase where you accept a
built reproducible product and make use of it, i.e. deploy it. An
example would be the debugger taking a reproducible binary and letting
the user debug it, showing the user the source code, etc.

We use the same mechanism in the deployment phase. Then
the BUILD_PATH_PREFIX_MAP must be setup with the logical
inverse of the mapping used during the build phase.

This PR generalized the functions in Build_path_prefix_map
and Location to facility the inverse map.

Also, this is part of a larger PR,
https://github.com/ocaml/ocaml/pull/12126, which itself
was part of
https://github.com/ocaml/ocaml/pull/12085, that is being split up
because it was too large. In addition to these changes, that PR
includes ocamltest enhancements plus the tests for
these changes. See it for prior discussion and the other changes.

For the new functions, see the '.mli' file for details.

1. utils/build_path_prefix_map.{ml,mli}

The new api functions are:

    val rewrite_first : map -> path -> path option
    val rewrite_all : map -> path -> path list

2. parsing/location.{ml,mli}

The new api functions are:

    val rewrite_find_first_existing: string -> string option
    val rewrite_find_all_existing_dirs: string -> string list

In addition to those new APIs, Location.absolute_path was modified
to do rewriting on absolute paths (in addition to relative paths
which it was already doing).

At the present time their is no code depending on these new APIs,
so the only functional change is the change to Location.absolute_path

The new API functions are used in the other parts of the PRs mentioned.

5 files changed, 132 insertions, 25 deletions

diff --git a/Changes b/Changes
index 4b6aec9992..479db7c2df 100644
--- a/Changes
+++ b/Changes
@@ -473,6 +473,9 @@ Working version
 
 ### Internal/compiler-libs changes:
 
+- #12138: Generalize interface for BUILD_PATH_PREFIX_MAP mapping.
+  (Richard L Ford, suggestions and review by Gabriel Scherer)
+
 - #10512: explain the compilation strategy for switches on constructors
   (Gabriel Scherer, review by Vincent Laviron)
 
diff --git a/parsing/location.ml b/parsing/location.ml
index a336e89dcd..980ad10306 100644
--- a/parsing/location.ml
+++ b/parsing/location.ml
@@ -157,12 +157,39 @@ let rewrite_absolute_path path =
   | None -> path
   | Some map -> Build_path_prefix_map.rewrite map path
 
+let rewrite_find_first_existing path =
+  match Misc.get_build_path_prefix_map () with
+  | None ->
+      if Sys.file_exists path then Some path
+      else None
+  | Some prefix_map ->
+    match Build_path_prefix_map.rewrite_all prefix_map path with
+    | [] ->
+      if Sys.file_exists path then Some path
+      else None
+    | matches ->
+      Some (List.find Sys.file_exists matches)
+
+let rewrite_find_all_existing_dirs path =
+  let ok path = Sys.file_exists path && Sys.is_directory path in
+  match Misc.get_build_path_prefix_map () with
+  | None ->
+      if ok path then [path]
+      else []
+  | Some prefix_map ->
+    match Build_path_prefix_map.rewrite_all prefix_map path with
+    | [] ->
+        if ok path then [path]
+        else []
+    | matches ->
+      match (List.filter ok matches) with
+      | [] -> raise Not_found
+      | results -> results
+
 let absolute_path s = (* This function could go into Filename *)
   let open Filename in
-  let s =
-    if not (is_relative s) then s
-    else (rewrite_absolute_path (concat (Sys.getcwd ()) s))
-  in
+  let s = if (is_relative s) then (concat (Sys.getcwd ()) s) else s in
+  let s = rewrite_absolute_path s in
   (* Now simplify . and .. components *)
   let rec aux s =
     let base = basename s in
diff --git a/parsing/location.mli b/parsing/location.mli
index 4d3de8d2ec..85bae4ff76 100644
--- a/parsing/location.mli
+++ b/parsing/location.mli
@@ -92,14 +92,78 @@ val separate_new_message: formatter -> unit
 val reset: unit -> unit
 
 
-(** {1 Printing locations} *)
+(** {1 Rewriting path } *)
 
 val rewrite_absolute_path: string -> string
-    (** rewrite absolute path to honor the BUILD_PATH_PREFIX_MAP
-        variable (https://reproducible-builds.org/specs/build-path-prefix-map/)
-        if it is set. *)
+(** [rewrite_absolute_path path] rewrites [path] to honor the
+    BUILD_PATH_PREFIX_MAP variable
+    if it is set. It does not check whether [path] is absolute or not.
+    The result is as follows:
+    - If BUILD_PATH_PREFIX_MAP is not set, just return [path].
+    - otherwise, rewrite using the mapping (and if there are no
+      matching prefixes that will just return [path]).
+
+    See
+    {{: https://reproducible-builds.org/specs/build-path-prefix-map/ }
+    the BUILD_PATH_PREFIX_MAP spec}
+    *)
+
+val rewrite_find_first_existing: string -> string option
+(** [rewrite_find_first_existing path] uses a BUILD_PATH_PREFIX_MAP mapping
+    and tries to find a source in mapping
+    that maps to a result that exists in the file system.
+    There are the following return values:
+    - [None], means either
+      {ul {- BUILD_PATH_PREFIX_MAP is not set and [path] does not exists, or}
+          {- no source prefixes of [path] in the mapping were found,}}
+    - [Some target], means [target] exists and either
+      {ul {- BUILD_PATH_PREFIX_MAP is not set and [target] = [path], or}
+          {- [target] is the first file (in priority
+             order) that [path] mapped to that exists in the file system.}}
+    - [Not_found] raised, means some source prefixes in the map
+      were found that matched [path], but none of them existed
+      in the file system. The caller should catch this and issue
+      an appropriate error message.
+
+    See
+    {{: https://reproducible-builds.org/specs/build-path-prefix-map/ }
+    the BUILD_PATH_PREFIX_MAP spec}
+    *)
+
+val rewrite_find_all_existing_dirs: string -> string list
+(** [rewrite_find_all_existing_dirs dir] accumulates a list of existing
+    directories, [dirs], that are the result of mapping a potentially
+    abstract directory, [dir], over all the mapping pairs in the
+    BUILD_PATH_PREFIX_MAP environment variable, if any. The list [dirs]
+    will be in priority order (head as highest priority).
+
+    The possible results are:
+    - [[]], means either
+      {ul {- BUILD_PATH_PREFIX_MAP is not set and [dir] is not an existing
+      directory, or}
+          {- if set, then there were no matching prefixes of [dir].}}
+    - [Some dirs], means dirs are the directories found. Either
+      {ul {- BUILD_PATH_PREFIX_MAP is not set and [dirs = [dir]], or}
+          {- it was set and [dirs] are the mapped existing directories.}}
+    - Not_found raised, means some source prefixes in the map
+      were found that matched [dir], but none of mapping results
+      were existing directories (possibly due to misconfiguration).
+      The caller should catch this and issue an appropriate error
+      message.
+
+    See
+    {{: https://reproducible-builds.org/specs/build-path-prefix-map/ }
+    the BUILD_PATH_PREFIX_MAP spec}
+    *)
 
 val absolute_path: string -> string
+ (** [absolute_path path] first makes an absolute path, [s] from [path],
+     prepending the current working directory if [path] was relative.
+     Then [s] is rewritten using [rewrite_absolute_path].
+     Finally the result is normalized by eliminating instances of
+     ['.'] or ['..']. *)
+
+(** {1 Printing locations} *)
 
 val show_filename: string -> string
     (** In -absname mode, return the absolute path for this filename.
diff --git a/utils/build_path_prefix_map.ml b/utils/build_path_prefix_map.ml
index 65d951f1c3..17cfac82e2 100644
--- a/utils/build_path_prefix_map.ml
+++ b/utils/build_path_prefix_map.ml
@@ -95,25 +95,24 @@ let decode_map str =
   | exception (Shortcut err) -> Error err
   | map -> Ok map
 
-let rewrite_opt prefix_map path =
-  let is_prefix = function
-    | None -> false
-    | Some { target = _; source } ->
-      String.length source <= String.length path
-      && String.equal source (String.sub path 0 (String.length source))
-  in
-  match
-    List.find is_prefix
-      (* read key/value pairs from right to left, as the spec demands *)
-      (List.rev prefix_map)
-  with
-  | exception Not_found -> None
+let make_target path : pair option -> path option = function
   | None -> None
-  | Some { source; target } ->
+  | Some { target; source } ->
+    let is_prefix =
+      String.length source <= String.length path
+        && String.equal source (String.sub path 0 (String.length source)) in
+    if is_prefix then
       Some (target ^ (String.sub path (String.length source)
                        (String.length path - String.length source)))
+    else None
+
+let rewrite_first prefix_map path =
+  List.find_map (make_target path) (List.rev prefix_map)
+
+let rewrite_all prefix_map path =
+  List.filter_map (make_target path) (List.rev prefix_map)
 
 let rewrite prefix_map path =
-  match rewrite_opt prefix_map path with
+  match rewrite_first prefix_map path with
   | None -> path
   | Some path -> path
diff --git a/utils/build_path_prefix_map.mli b/utils/build_path_prefix_map.mli
index dbcc8dc16f..d8ec9caf4d 100644
--- a/utils/build_path_prefix_map.mli
+++ b/utils/build_path_prefix_map.mli
@@ -18,6 +18,9 @@
   {b Warning:} this module is unstable and part of
   {{!Compiler_libs}compiler-libs}.
 
+  See
+  {{: https://reproducible-builds.org/specs/build-path-prefix-map/ }
+  the BUILD_PATH_PREFIX_MAP spec}
 *)
 
 
@@ -38,10 +41,21 @@ type map = pair option list
 val encode_map : map -> string
 val decode_map : string -> (map, error_message) result
 
-val rewrite_opt : map -> path -> path option
-(** [rewrite_opt map path] tries to find a source in [map]
+val rewrite_first : map -> path -> path option
+(** [rewrite_first map path] tries to find a source in [map]
     that is a prefix of the input [path]. If it succeeds,
     it replaces this prefix with the corresponding target.
     If it fails, it just returns [None]. *)
 
+val rewrite_all : map -> path -> path list
+(** [rewrite_all map path] finds all sources in [map]
+    that are a prefix of the input [path]. For each matching
+    source, in priority order, it replaces this prefix with
+    the corresponding target and adds the result to
+    the returned list.
+    If there are no matches, it just returns [[]]. *)
+
 val rewrite : map -> path -> path
+(** [rewrite path] uses [rewrite_first] to try to find a
+    mapping for path. If found, it returns that, otherwise
+    it just returns [path]. *)