diff options
| -rw-r--r-- | Changes | 3 | ||||
| -rw-r--r-- | parsing/location.ml | 35 | ||||
| -rw-r--r-- | parsing/location.mli | 72 | ||||
| -rw-r--r-- | utils/build_path_prefix_map.ml | 29 | ||||
| -rw-r--r-- | utils/build_path_prefix_map.mli | 18 |
5 files changed, 132 insertions, 25 deletions
@@ -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]. *) |