utils: import build_path_prefix_map library

This library is imported from

  <https://gitlab.com/gasche/build_path_prefix_map/>

commit 811691e479b38c0e6c1c0e5c853c555a63177ee3

2 files changed, 128 insertions, 0 deletions

diff --git a/utils/build_path_prefix_map.ml b/utils/build_path_prefix_map.ml
new file mode 100644
index 0000000000..40e3e8e3a4
--- /dev/null
+++ b/utils/build_path_prefix_map.ml
@@ -0,0 +1,104 @@
+type path = string
+type path_prefix = string
+type error_message = string
+
+let errorf fmt = Printf.kprintf (fun err -> Error err) fmt
+
+let encode_prefix str =
+  let buf = Buffer.create (String.length str) in
+  let push_char = function
+    | '%' -> Buffer.add_string buf "%#"
+    | '=' -> Buffer.add_string buf "%+"
+    | ':' -> Buffer.add_string buf "%."
+    | c -> Buffer.add_char buf c
+  in
+  String.iter push_char str;
+  Buffer.contents buf
+
+let decode_prefix str =
+  let buf = Buffer.create (String.length str) in
+  let rec loop i =
+    if i >= String.length str
+    then Ok (Buffer.contents buf)
+    else match str.[i] with
+      | ('=' | ':') as c ->
+        errorf "invalid character '%c' in key or value" c
+      | '%' ->
+        let push c = Buffer.add_char buf c; loop (i + 2) in
+        if i + 1 = String.length str then
+          errorf "invalid encoded string %S (trailing '%%')" str
+        else begin match str.[i + 1] with
+            | '#' -> push '%'
+            | '+' -> push '='
+            | '.' -> push ':'
+            | c -> errorf "invalid %%-escaped character '%c'" c
+        end
+      | c ->
+        Buffer.add_char buf c;
+        loop (i + 1)
+  in loop 0
+
+type pair = { target: path_prefix; source : path_prefix }
+
+let encode_pair { target; source } =
+  String.concat "=" [encode_prefix target; encode_prefix source]
+
+let decode_pair str =
+  match String.index str '=' with
+  | exception Not_found ->
+    errorf "invalid key/value pair %S, no '=' separator" str
+  | equal_pos ->
+    let encoded_target = String.sub str 0 equal_pos in
+    let encoded_source =
+      String.sub str (equal_pos + 1) (String.length str - equal_pos - 1) in
+    match decode_prefix encoded_target, decode_prefix encoded_source with
+    | Ok target, Ok source -> Ok { target; source }
+    | ((Error _ as err), _) | (_, (Error _ as err)) -> err
+
+type map = pair option list
+
+let encode_map map =
+  let encode_elem = function
+    | None -> ""
+    | Some pair -> encode_pair pair
+  in
+  List.map encode_elem map
+  |> String.concat ":"
+
+let decode_map str =
+  let exception Shortcut of error_message in
+  let decode_or_empty = function
+    | "" -> None
+    | pair ->
+      begin match decode_pair pair with
+        | Ok str -> Some str
+        | Error err -> raise (Shortcut err)
+      end
+  in
+  let pairs = String.split_on_char ':' str in
+  match List.map decode_or_empty pairs with
+  | 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
+  | None -> None
+  | Some { source; target } ->
+      Some (target ^ (String.sub path (String.length source)
+                       (String.length path - String.length source)))
+
+let rewrite prefix_map path =
+  match rewrite_opt 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
new file mode 100644
index 0000000000..c21f4583d6
--- /dev/null
+++ b/utils/build_path_prefix_map.mli
@@ -0,0 +1,24 @@
+type path = string
+type path_prefix = string
+type error_message = string
+
+val encode_prefix : path_prefix -> string
+val decode_prefix : string -> (path_prefix, error_message) result
+
+type pair = { target: path_prefix; source : path_prefix }
+
+val encode_pair : pair -> string
+val decode_pair : string -> (pair, error_message) result
+
+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]
+    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 : map -> path -> path