Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 357 lines (297 sloc) 12.013 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 let print_err fmt = Printf.fprintf stderr fmt
19 (* The logger is not yet set. And for invocation messages, better not use it *)
20
21 type args = string list
22
23 let get_argv, set_argv =
24 let argv = ref (match Array.to_list Sys.argv with [] -> [] | _0::args -> args) in
25 (fun () -> !argv),
26 (fun x -> argv := x)
27
28 let is_empty args = [] = args
29
30 let to_list args = args
31
32 let argv_to_string () = String.concat " " (get_argv())
33
34 (* ------------------------------------------------------------ *)
35 (* Low-level parsers *)
36 (* ------------------------------------------------------------ *)
37
38 type 'a param_parser = args -> 'a option * args * args
39 (* Returns acc, skipped args, remaining args. Arguments parsed are not returned *)
40
41 let failopt f x = try Some (f x) with Failure _ -> None
42
43 let int = function
44 | x::args -> failopt int_of_string x, [], args
45 | [] -> None, [], []
46
47 let string = function
48 | x::args when (String.length x = 0 || x.[0] <> '-') -> Some x, [], args
49 | _ -> None, [], []
50
51 let anystring = function
52 | x::args -> Some x, [], args
53 | [] -> None, [], []
54
55 let float = function
56 | x::args -> failopt float_of_string x, [], args
57 | [] -> None, [], []
58
59 let bool = function
60 | x::args -> failopt bool_of_string x, [], args
61 | [] -> None, [], []
62
63 let unit args = Some (), [], args
64
65 let stringset list = function
66 | x::args -> (try Some (List.assoc x list), [], args with Not_found -> None, [], args)
67 | [] -> None, [], []
68
3bb69fb [feature] ServerArg: added a parser for arguments as lists
Louis Gesbert authored
69 let list separator parse = function
70 | [] -> Some [], [], []
71 | x::args ->
72 try
73 Some (
74 List.map
75 (fun x -> match parse [x] with Some x, [], [] -> x | _ -> raise Exit)
76 (Base.String.slice separator x)
77 ),
78 [], args
79 with Exit ->
80 None, [], args
81
82
fccc685 Initial open-source release
MLstate authored
83 let option parse args = match parse args with
84 | (Some _) as x, skipped, args -> Some x, skipped, args
85 | _ -> Some None, [], args
86
87 let pair pa pb args = match pa args with
88 | None, skipped, args -> None, skipped, args
89 | Some x, skipped, args -> match pb args with
90 | None, skipped2, args -> None, skipped@skipped2, args
91 | Some y, skipped2, args -> Some (x,y), skipped@skipped2, args
92
93 let check parse f args = match parse args with
94 | None, skipped, args -> None, skipped, args
95 | Some x, skipped, args2 ->
96 if f x then Some x, skipped, args2
97 else None, [], args
98
99 let keep parse args =
100 let res, _skipped, _args = parse args in
101 res, [], args
102
103 let wrap param f args = match param args with
104 | Some x, skipped, args -> Some (f x), skipped, args
105 | None, skipped, args -> None, skipped, args
106
107 let wrap_opt param f args = match param args with
108 | None, skipped, args -> None, skipped, args
109 | Some x, skipped, args2 -> match f x with
110 | None -> None, [], args
111 | res -> res, skipped, args2
112
113 let func param f = fun acc -> fun args -> wrap param (f acc) args
114
115 let func_opt param f = fun acc -> fun args -> wrap_opt param (f acc) args
116
117 let skip = function
118 | x::args -> Some (), [x], args
119 | [] -> None, [], []
120
121 let skip_all args = Some (), args, []
122
123 let rec fold effect acc = function
124 | [] -> Some acc, [], []
125 | args ->
126 match effect acc args with
127 | Some acc, skipped, args ->
128 let acc, skipped2, args = fold effect acc args in
129 acc, skipped @ skipped2, args
130 | _ -> Some acc, [], args
131
132 let fold_until str effect acc =
133 fold
134 (fun acc -> function
135 | [] -> Some acc,[],[]
136 | (x::_) as args -> if x = str then Some acc,args,[] else effect acc args)
137 acc
138
139 let rec fold_all effect acc remainings_args =
140 match remainings_args with
141 | [] -> Some acc, [], []
142 | arg::rest as args->
143 match effect acc args with
144 | Some acc, skipped, args ->
145 let acc, skipped2, args = fold_all effect acc args in
146 acc, skipped @ skipped2, args
147 | None, skipped, _args ->
148 let acc, skipped2, args = fold_all effect acc rest in
149 acc, arg :: skipped @ skipped2, args
150
151 let skip_str str effect = function
152 | [] -> Some None, [], []
153 | (x::r) as args ->
154 if x = str then option effect r
155 else if List.mem str args then None, [], args
156 else option effect args
157
158 let push str args = Some (), [str], args
159
160
161 (**
162 * {1 Alternative API}
163 *)
164 type 'a state = No_more_params of 'a
165 | More_params of 'a
166 | Maybe_params of 'a
167
168 type 'a instruction = 'a state option
169
170
171 let make_arg_parser ~(names: string list) ~(param_doc:string) ~(doc:string) ~(initialize:'a(*float*) -> 'a(*float*) state) ~(step:'a(*float*) -> string -> 'a(*float*) instruction) =
172 let rec parse_params (state: 'a(*float*) state) args used : ('a(*float*) option * args * args) =
173 match state with
174 | No_more_params x -> (*Nothing to do, so job finished*)
175 (Some x, [], args)
176 | Maybe_params x ->
177 begin
178 match args with
179 | [] -> (*No args left, so job finished*)
180 (Some x, [], args)
181 | h::t ->
182 match step x h with
183 | None -> (*Optional arg doesn't parse, so job finished*)
184 (Some x, [], args)
185 | Some (No_more_params x) -> (*This was the last arg, job finished*)
186 (Some x, [], t)
187 | Some i -> (*Otherwise, continue job*)
188 parse_params i t (h::used)
189 end
190 | More_params x ->
191 begin
192 match args with
193 | [] -> (*No args left, this is a failure*)
194 (None, used, [])
195 | h::t ->
196 match step x h with
197 | None -> (*Arg doesn't parse, this is a failure*)
198 (None, used, args)
199 | Some (No_more_params x) ->
200 (Some x, [], t)
201 | Some i -> (*So far, so good*)
202 parse_params i t (h::used)
203 end
204 in
205 (*let unwrap = function No_more_params x | Maybe_params x | More_params x -> x in
206 let parse (state:'a(*float*)) args = match parse_params (initialize state) args [] with
207 | (None, skipped, rest) -> (None, skipped, rest)
208 | (Some x, skipped, rest) -> (Some (unwrap x), skipped, rest)*)
209 let parse state args = parse_params (initialize state) args []
210 in
211 (names, parse, param_doc, doc)
212
213
214 (* ------------------------------------------------------------ *)
215 (* High-level parsers *)
216 (* ------------------------------------------------------------ *)
217
218 type 'a arg_parser = string list * ('a -> 'a param_parser) * string * string
219
220 let rec pp_justify f s =
221 let a,b = Base.String.split_char ' ' s in
222 Format.pp_print_string f a;
223 if b <> "" then
224 (Format.pp_print_space f ();
225 pp_justify f b)
226
227 let doc_string title speclist =
228 let rec pplist f = function
229 | s::[] -> Format.pp_print_string f s
230 | s::r -> Format.pp_print_string f s; Format.pp_print_space f (); pplist f r
231 | [] -> ()
232 in
233 Format.fprintf Format.str_formatter "@[<v4>%s:@\n%a@]@."
234 (String.capitalize title)
235 (fun f ->
236 List.iter
237 (fun (names,_,params_doc,doc) ->
238 Format.fprintf f "@[<v>@[<hov>%a%a@]@;<1 12>@[<hov>%a@]@]@," pplist names
239 (fun f s -> if s <> "" then Format.fprintf f "@;<1 4>%s" s) params_doc
240 pp_justify doc))
241 speclist;
242 Format.flush_str_formatter ()
243
244 let make_parser ?(final=false) ?(nohelp=false) title speclist acc0 args0 =
245 let rec do_args (acc,rev_args) = function
246 | [] -> (Some acc, List.rev rev_args, [])
247 | arg::args ->
248 let rec do_specs = function
249 | (names,effect,params_doc,_doc)::specs ->
250 if List.mem arg names then
251 match effect acc args with
252 | Some acc, skipped_args, args ->
253 do_args (acc, List.rev_append skipped_args rev_args) args
254 | _ ->
255 print_err "Invalid parameter for option %s, in %s. Syntax:\n %s %s\n"
256 arg title arg params_doc;
257 raise Exit
258 else
259 do_specs specs
260 | [] ->
261 if not(nohelp) && (arg = "--help" || arg = "-help" || arg = "-h" || arg = "-?") then
262 (print_err "%s" (doc_string title speclist);
263 if final then raise Exit
264 else Some acc0,args0,[])
265 else
266 do_args (acc, arg::rev_args) args
267 in
268 do_specs speclist
269 in
270 do_args (acc0,[]) args0
271
272 let filter_functional args acc parse =
273 match parse acc args with
274 | None, _, _ -> acc, args
275 | Some acc, skipped_args, args -> acc, skipped_args @ args
276
277 let filter acc parse =
278 let args = get_argv() in
279 match parse acc args with
280 | None, _, _ -> acc
281 | Some acc, skipped_args, args ->
282 set_argv (skipped_args @ args);
283 acc
284
285 let extract_prefix pfx =
286 let rec do_args (take,leave) args = match args with
287 | [] -> List.rev take, List.rev leave
288 | arg::rest ->
289 if arg = "--" then List.rev take, List.rev_append leave args
290 else if arg = "--help" then do_args (arg::take, arg::leave) rest
291 else if Base.String.is_prefix pfx arg then
292 match rest with
293 | param::rest2 when not (Base.String.is_prefix "-" param) ->
294 do_args (param::arg::take, leave) rest2
295 | _ ->
296 do_args (arg::take, leave) rest
297 else do_args (take, arg::leave) rest
298 in
299 let args = get_argv() in
300 let take,leave = do_args ([],[]) args in
301 set_argv leave;
302 take
303
304 (* ------------------------------------------------------------ *)
305 (* Pre-defined parsers *)
306 (* ------------------------------------------------------------ *)
307 let parse_addr =
308 let parse str =
309 let host,port = Base.String.split_char_last ':' str in
310 try
311 let portopt =
312 if port = "" then None
313 else
314 let p = int_of_string port in
315 if p < 0xffff then Some p
316 else
317 failwith "Port number is too high: "
318 in
319 Some ((Unix.gethostbyname host).Unix.h_addr_list.(0), portopt)
320 with
321 | Failure s -> prerr_endline ("Error: invalid port. "^s^port); None
322 | Not_found -> prerr_endline ("Error: host not found: "^host); None
323 in
324 wrap_opt string parse
325
326
327 (* ------------------------------------------------------------ *)
328 (* Binding with arg *)
329 (* ------------------------------------------------------------ *)
330
331 module A = Base.Arg
332 module String = Base.String
333
334 let (!>) tag f = func tag (fun acc arg -> f arg; acc)
335
336 let import_arg_spec = function
337 | A.Unit f -> !> unit f
338 | A.Bool f -> !> bool f
339 | A.Set r -> !> unit (fun () -> r := true)
340 | A.Clear r -> !> unit (fun () -> r := false)
341 | A.String f -> !> string f
342 | A.Set_string r -> !> string (fun s -> r := s)
343 | A.Int f -> !> int f
344 | A.Set_int r -> !> int (fun i -> r := i)
345 | A.Float f -> !> float f
346 | A.Set_float r -> !> float (fun f -> r := f)
347
348 (* The rest is not implemented, you can add it if you need *)
349 | _ -> assert false
350
351 let import_arg_opt (key, spec, doc) =
352 let spec = import_arg_spec spec in
353 let arg_doc, doc = String.split_char ' ' doc in
354 [key], spec, arg_doc, doc
355
356 let import_arg_options opts = List.map import_arg_opt opts
Something went wrong with that request. Please try again.