1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Pierre Chambart, OCamlPro *)
6 (* Mark Shinwell and Leo White, Jane Street Europe *)
7 (* *)
8 (* Copyright 2015--2016 OCamlPro SAS *)
9 (* Copyright 2015--2016 Jane Street Group LLC *)
10 (* *)
11 (* All rights reserved. This file is distributed under the terms of *)
12 (* the GNU Lesser General Public License version 2.1, with the *)
13 (* special exception on linking described in the file LICENSE. *)
14 (* *)
15 (**************************************************************************)
16
17 let fatal err =
18 prerr_endline err;
19 exit 2
20
21 module Make (S : sig
22 module Key : sig
23 type t
24 val of_string : string -> t
25 module Map : Map.S with type key = t
26 end
27
28 module Value : sig
29 type t
30 val of_string : string -> t
31 end
32 end) = struct
33 type parsed = {
34 base_default : S.Value.t;
35 base_override : S.Value.t S.Key.Map.t;
36 user_default : S.Value.t option;
37 user_override : S.Value.t S.Key.Map.t;
38 }
39
40 let default v =
41 { base_default = v;
42 base_override = S.Key.Map.empty;
43 user_default = None;
44 user_override = S.Key.Map.empty; }
45
46 let set_base_default value t =
47 { t with base_default = value }
48
49 let add_base_override key value t =
50 { t with base_override = S.Key.Map.add key value t.base_override }
51
52 let reset_base_overrides t =
53 { t with base_override = S.Key.Map.empty }
54
55 let set_user_default value t =
56 { t with user_default = Some value }
57
58 let add_user_override key value t =
59 { t with user_override = S.Key.Map.add key value t.user_override }
60
61 exception Parse_failure of exn
62
63 let parse_exn str ~update =
64 (* Is the removal of empty chunks really relevant here? *)
65 (* (It has been added to mimic the old Misc.String.split.) *)
66 let values = String.split_on_char ',' str |> List.filter ((<>) "") in
67 let parsed =
68 List.fold_left (fun acc value ->
69 match String.index value '=' with
70 | exception Not_found ->
71 begin match S.Value.of_string value with
72 | value -> set_user_default value acc
73 | exception exn -> raise (Parse_failure exn)
74 end
75 | equals ->
76 let key_value_pair = value in
77 let length = String.length key_value_pair in
78 assert (equals >= 0 && equals < length);
79 if equals = 0 then begin
80 raise (Parse_failure (
81 Failure "Missing key in argument specification"))
82 end;
83 let key =
84 let key = String.sub key_value_pair 0 equals in
85 try S.Key.of_string key
86 with exn -> raise (Parse_failure exn)
87 in
88 let value =
89 let value =
90 String.sub key_value_pair (equals + 1) (length - equals - 1)
91 in
92 try S.Value.of_string value
93 with exn -> raise (Parse_failure exn)
94 in
95 add_user_override key value acc)
96 !update
97 values
98 in
99 update := parsed
100
101 let parse str help_text update =
102 match parse_exn str ~update with
103 | () -> ()
104 | exception (Parse_failure exn) ->
105 fatal (Printf.sprintf "%s: %s" (Printexc.to_string exn) help_text)
106
107 type parse_result =
108 | Ok
109 | Parse_failed of exn
110
111 let parse_no_error str update =
112 match parse_exn str ~update with
113 | () -> Ok
114 | exception (Parse_failure exn) -> Parse_failed exn
115
116 let get ~key parsed =
117 match S.Key.Map.find key parsed.user_override with
118 | value -> value
119 | exception Not_found ->
120 match parsed.user_default with
121 | Some value -> value
122 | None ->
123 match S.Key.Map.find key parsed.base_override with
124 | value -> value
125 | exception Not_found -> parsed.base_default
126
127 end
128