package / ocaml-base-compiler.4.10.0 / utils / build_path_prefix_map.ml
1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Gabriel Scherer, projet Parsifal, INRIA Saclay *)
6 (* *)
7 (* Copyright 2017 Institut National de Recherche en Informatique et *)
8 (* en Automatique. *)
9 (* *)
10 (* All rights reserved. This file is distributed under the terms of *)
11 (* the GNU Lesser General Public License version 2.1, with the *)
12 (* special exception on linking described in the file LICENSE. *)
13 (* *)
14 (**************************************************************************)
15
16 type path = string
17 type path_prefix = string
18 type error_message = string
19
20 let errorf fmt = Printf.kprintf (fun err -> Error err) fmt
21
22 let encode_prefix str =
23 let buf = Buffer.create (String.length str) in
24 let push_char = function
25 | '%' -> Buffer.add_string buf "%#"
26 | '=' -> Buffer.add_string buf "%+"
27 | ':' -> Buffer.add_string buf "%."
28 | c -> Buffer.add_char buf c
29 in
30 String.iter push_char str;
31 Buffer.contents buf
32
33 let decode_prefix str =
34 let buf = Buffer.create (String.length str) in
35 let rec loop i =
36 if i >= String.length str
37 then Ok (Buffer.contents buf)
38 else match str.[i] with
39 | ('=' | ':') as c ->
40 errorf "invalid character '%c' in key or value" c
41 | '%' ->
42 let push c = Buffer.add_char buf c; loop (i + 2) in
43 if i + 1 = String.length str then
44 errorf "invalid encoded string %S (trailing '%%')" str
45 else begin match str.[i + 1] with
46 | '#' -> push '%'
47 | '+' -> push '='
48 | '.' -> push ':'
49 | c -> errorf "invalid %%-escaped character '%c'" c
50 end
51 | c ->
52 Buffer.add_char buf c;
53 loop (i + 1)
54 in loop 0
55
56 type pair = { target: path_prefix; source : path_prefix }
57
58 let encode_pair { target; source } =
59 String.concat "=" [encode_prefix target; encode_prefix source]
60
61 let decode_pair str =
62 match String.index str '=' with
63 | exception Not_found ->
64 errorf "invalid key/value pair %S, no '=' separator" str
65 | equal_pos ->
66 let encoded_target = String.sub str 0 equal_pos in
67 let encoded_source =
68 String.sub str (equal_pos + 1) (String.length str - equal_pos - 1) in
69 match decode_prefix encoded_target, decode_prefix encoded_source with
70 | Ok target, Ok source -> Ok { target; source }
71 | ((Error _ as err), _) | (_, (Error _ as err)) -> err
72
73 type map = pair option list
74
75 let encode_map map =
76 let encode_elem = function
77 | None -> ""
78 | Some pair -> encode_pair pair
79 in
80 List.map encode_elem map
81 |> String.concat ":"
82
83 let decode_map str =
84 let exception Shortcut of error_message in
85 let decode_or_empty = function
86 | "" -> None
87 | pair ->
88 begin match decode_pair pair with
89 | Ok str -> Some str
90 | Error err -> raise (Shortcut err)
91 end
92 in
93 let pairs = String.split_on_char ':' str in
94 match List.map decode_or_empty pairs with
95 | exception (Shortcut err) -> Error err
96 | map -> Ok map
97
98 let rewrite_opt prefix_map path =
99 let is_prefix = function
100 | None -> false
101 | Some { target = _; source } ->
102 String.length source <= String.length path
103 && String.equal source (String.sub path 0 (String.length source))
104 in
105 match
106 List.find is_prefix
107 (* read key/value pairs from right to left, as the spec demands *)
108 (List.rev prefix_map)
109 with
110 | exception Not_found -> None
111 | None -> None
112 | Some { source; target } ->
113 Some (target ^ (String.sub path (String.length source)
114 (String.length path - String.length source)))
115
116 let rewrite prefix_map path =
117 match rewrite_opt prefix_map path with
118 | None -> path
119 | Some path -> path
120