Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 321 lines (287 sloc) 11.103 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 (* depends *)
19 module String = BaseString
20
21 type simple_completion =
22 | Nothing
23 | File of string
24 | Dir
25 | Oneof of string list
26 type completion = {params : simple_completion list; stop : bool}
27
28 type spec =
29 | Unit of (unit -> unit)
30 | Bool of (bool -> unit)
31 | Set of bool ref
32 | Clear of bool ref
33 | String of (string -> unit)
34 | Set_string of string ref
35 | Int of (int -> unit)
36 | Set_int of int ref
37 | Float of (float -> unit)
38 | Set_float of float ref
39 | Tuple of spec list
40 | Symbol of string list * (string -> unit)
41 | Rest of (string -> unit)
42 | Complete of spec * completion
43
534ca4d @OpaOnWindowsNow [feature] syntax: introduces js-like syntax
OpaOnWindowsNow authored
44 let spec_fun_of_assoc f assoc =
45 Symbol (List.map fst assoc, (fun s -> f (List.assoc s assoc)))
fccc685 Initial open-source release
MLstate authored
46 let spec_of_assoc ref_ assoc =
47 Symbol (List.map fst assoc, (fun s -> ref_ := List.assoc s assoc))
48 let spec_opt_of_assoc ref_ assoc =
49 Symbol (List.map fst assoc, (fun s -> ref_ := Some (List.assoc s assoc)))
50 let spec_of_opt_assoc ref_ default assoc =
51 Unit (fun () ->
52 if !Arg.current+1 < Array.length Sys.argv then
53 let s = Sys.argv.(!Arg.current+1) in
54 if s <> "" && s.[0] = '-' then
55 ref_ := default
56 else (
57 try
58 ref_ := List.assoc s assoc;
59 incr Arg.current;
60 with Not_found ->
61 ref_ := default
62 )
63 else
64 ref_ := default
65 )
66
67 let rec convert_spec_to_old_arg = function
68 | Unit x -> Arg.Unit x
69 | Bool x -> Arg.Bool x
70 | Set x -> Arg.Set x
71 | Clear x -> Arg.Clear x
72 | String x -> Arg.String x
73 | Set_string x -> Arg.Set_string x
74 | Int x -> Arg.Int x
75 | Set_int x -> Arg.Set_int x
76 | Float x -> Arg.Float x
77 | Set_float x -> Arg.Set_float x
78 | Tuple x -> Arg.Tuple (List.map convert_spec_to_old_arg x)
79 | Symbol (x,y) -> Arg.Symbol (x,y)
80 | Rest x -> Arg.Rest x
81 | Complete (x,_) -> convert_spec_to_old_arg x
82 let rec convert_spec_from_old_arg = function
83 | Arg.Unit x -> Unit x
84 | Arg.Bool x -> Bool x
85 | Arg.Set x -> Set x
86 | Arg.Clear x -> Clear x
87 | Arg.String x -> String x
88 | Arg.Set_string x -> Set_string x
89 | Arg.Int x -> Int x
90 | Arg.Set_int x -> Set_int x
91 | Arg.Float x -> Float x
92 | Arg.Set_float x -> Set_float x
93 | Arg.Tuple x -> Tuple (List.map convert_spec_from_old_arg x)
94 | Arg.Symbol (x,y) -> Symbol (x,y)
95 | Arg.Rest x -> Rest x
96 let convert_from_old_arg_one (x,spec,y) = (x,convert_spec_from_old_arg spec,y)
97 let convert_to_old_arg_one (x,spec,y) = (x,convert_spec_to_old_arg spec,y)
98 let convert_to_old_arg l = List.map convert_to_old_arg_one l
99 let convert_from_old_arg l = List.map convert_from_old_arg_one l
100
101 (* stdlib's functions *)
102 let parse p = Arg.parse (convert_to_old_arg p)
103 let parse_argv ?current x p = Arg.parse_argv ?current x (convert_to_old_arg p)
104 let usage p = Arg.usage (convert_to_old_arg p)
105 let align p = convert_from_old_arg (Arg.align (convert_to_old_arg p))
106 let current = Arg.current
107 type key = Arg.key
108 type doc = Arg.doc
109 type usage_msg = Arg.usage_msg
110 type anon_fun = Arg.anon_fun
111 exception Help = Arg.Help
112 exception Bad = Arg.Bad
113
b25e4e4 [enhance] baseArg: added write_simple_manpage
Mathieu Baudet authored
114 (* -- generate a simple manpage -- *)
115
116 let date_manpage () =
117 let dt = Unix.gmtime (Unix.time ()) in
118 (Date.fullmonth.(dt.Unix.tm_mon))
119 ^ " " ^ (string_of_int (dt.Unix.tm_mday))
120 ^ ", " ^ (string_of_int (dt.Unix.tm_year+1900))
121
122
123 (* todo: move to baseList *)
124 let pretty_list_to_string empty left separator right = function
125 | [] -> empty
126 | x::q -> (List.fold_left (fun s y -> s ^ separator ^ y) (left ^ x) q) ^ right
127
128 let split_option_args str =
129 let reg = Str.regexp "[>)\"}] " in
130 try
131 let pos = (Str.search_forward reg str 0) + 1
132 in
133 (String.ltrim (Str.string_before str pos)), (String.ltrim (Str.string_after str pos))
134 with
135 Not_found -> "", (String.ltrim str)
136
137 let print_spec file (key, spec, doc) =
138 let key = String.replace key "-" "\\-" in
139 let options, doc = split_option_args doc in
140 match spec with
141 | Symbol (l, _) -> Printf.fprintf file ".TP\n%s %s %s\n%s\n" key (pretty_list_to_string "<none>" "{" "|" "}" l) options doc
142 | _ -> Printf.fprintf file ".TP\n%s %s\n%s\n" key options doc; ()
143
144 let add_help speclist =
145 let add help =
146 if List.exists (fun (x, _, _) -> x = help) speclist then []
147 else [help, Unit (fun x->x), " Display this list of options"]
148 in
149 speclist @ (add "-help") @ (add "--help")
150
151 let write_simple_manpage
152 ~cmdname ~section
153 ?(centerfooter=(date_manpage ()))
154 ?(leftfooter="") ?(centerheader="")
4a76457 [enhance] serverArg, baseArg: made summary optional in write_simple_m…
Mathieu Baudet authored
155 ?(summary="") ?(synopsis="") ?(description="") ?options ?(other=[])
b25e4e4 [enhance] baseArg: added write_simple_manpage
Mathieu Baudet authored
156 file =
157 Printf.fprintf file ".TH \"%s\" \"%s\" \"%s\" \"%s\" \"%s\"\n" cmdname (string_of_int section) centerfooter leftfooter centerheader;
4a76457 [enhance] serverArg, baseArg: made summary optional in write_simple_m…
Mathieu Baudet authored
158 if summary <> "" then
159 Printf.fprintf file ".SH NAME\n%s \\- %s\n" cmdname summary
160 else
161 Printf.fprintf file ".SH NAME\n%s\n" cmdname;
162 if synopsis <> "" then Printf.fprintf file ".SH SYNOPSIS\n%s\n" synopsis;
163 if description <> "" then Printf.fprintf file ".SH DESCRIPTION\n%s\n" description;
b25e4e4 [enhance] baseArg: added write_simple_manpage
Mathieu Baudet authored
164 begin match options with None -> () | Some(speclist) -> begin
165 Printf.fprintf file ".SH OPTIONS\n";
166 List.iter (print_spec file) (add_help speclist);
167 end end;
168 List.iter (fun (title, content) -> Printf.fprintf file ".SH %s\n%s\n" title content) other;
169 ()
170
171 (* --- *)
172
fccc685 Initial open-source release
MLstate authored
173
174 let sort_by_name l = List.stable_sort (fun (x,_,_) (y,_,_) -> compare (x:string) y) l
175 let sort l = (* also makes names unique *)
176 let rec aux acc = function
177 | [] -> List.rev acc
178 | [x] -> List.rev (x :: acc)
179 | ((s1,_,_) as v1) :: ((s2,_,_) :: tl2 as tl) ->
180 if s1 = s2 then (
181 if (try (Sys.getenv "MLSTATE_TESTING") = "0" with Not_found -> true) then
182 Printf.eprintf "Internal warning: The option %s is matched several times in the command line parser.\n%!" s1;
183 (* cannot call omanager from here, nor debugVariables *)
184 aux acc (v1 :: tl2) (* keeping the first one in the list *)
185 ) else
186 aux (v1 :: acc) tl in
187 aux [] (sort_by_name l)
188
189 let merge ({params = l1; stop = b1} as left) {params = l2; stop = b2} =
190 if b1 then left else {params = l1 @ l2; stop = b1 || b2}
191
192 let rec convert_spec = function
193 | Bool _ -> {params = [Oneof ["true";"false"]]; stop = false} (* possibly case insensitive ? *)
194 | Unit _
195 | Set _
196 | Clear _ -> {params = []; stop = false} (* nothing follows *)
197 | String _
198 | Set_string _
199 | Int _
200 | Set_int _
201 | Float _
202 | Set_float _ -> {params = [Nothing]; stop = false} (* no completion possible *)
203 | Tuple specs ->
204 let l = List.map convert_spec specs in
205 List.fold_left merge {params = []; stop = false} l
206 | Symbol (sl,_) -> {params = [Oneof sl]; stop = false}
207 | Rest _ -> {params = []; stop = true}
208 | Complete (_,comp) -> comp
209 let convert_one (key,spec,_) =
210 (key, convert_spec spec)
211 let convert parse =
212 let completion = List.map convert_one parse in
213 List.fold_left (fun completion builtin_option ->
214 if List.mem_assoc builtin_option completion then
215 completion
216 else
217 (builtin_option,{params = []; stop = false}) :: completion) completion ["-help";"--help"]
218
219 let stringify_simple_completion = function
220 | Nothing -> "COMPREPLY=()"
221 | File pattern -> Printf.sprintf "_filedir %s" pattern
222 | Dir -> "_filedir -d"
223 | Oneof sl -> Printf.sprintf "COMPREPLY=($(compgen -W '%s' -- ${cur}))" (String.concat " " sl)
224 let stringify_completion (k,l) =
225 if l = [] then
226 ""
227 else
228 let main,_ =
229 List.fold_left (fun (acc,i) sc ->
230 let acc =
231 if i = 0 then acc ^ Printf.sprintf "
232 if [ \"$n\" -eq %d ]; then
233 %s" (i+1) (stringify_simple_completion sc)
234 else acc ^ Printf.sprintf "
235 elif [ \"$n\" -eq %d ]; then
236 %s" (i+1) (stringify_simple_completion sc) in
237 acc,(i+1)
238 ) ("",0) l in
239 Printf.sprintf "
240 %s)%s
241 else
242 did_something=0
243 fi;;" k main
244
245 (* making sure we have only letters in the name, to avoid function containing wierd chars
246 * (like '/') *)
247 let remove_illegal_chars s =
248 "prefix" ^ Str.global_replace (Str.regexp "[^a-zA-Z]") "" s
249
250 let stringify ?name ?(names=[]) ?(default=File "*") l =
251 let one_name,names =
252 match name,names with
253 | None, [] -> Sys.argv.(0), [Filename.basename Sys.argv.(0)]
254 | None, (h :: _ as l) -> h, l
255 | Some v, l -> v, v :: l in
256 let one_name = remove_illegal_chars one_name in
257 let stops = List.map fst (List.filter (fun (_,{params=_; stop = b}) -> b) l) in
258 let prologue = Printf.sprintf "\
259 # this file was generated by Base.Arg.add_bash_completion
260 # do not modify by hand
261
262 shopt -s extglob
263
264 _%s() {
265 COMPREPLY=()
266 local cur=`_get_cword`
267 " one_name in
268 let check_stop = Printf.sprintf "
269 local latest_minus=$COMP_CWORD
270 local stop=(%s)
271
272 for (( i = 0; i < $COMP_CWORD; i ++ )); do
273 for j in \"${stop[@]}\"; do
274 [ \"${COMP_WORDS[i]}\" = \"$j\" ] && return 0
275 done
276 [[ \"${COMP_WORDS[i]}\" =~ -.* ]] && latest_minus=$i
277 done
278
279 local n=$(( COMP_CWORD - latest_minus ))
280 " (String.concat " " stops) in
281 let complete = Printf.sprintf "
282 local did_something=0
283 if [ \"$n\" -gt 0 ]; then
284 did_something=1
285 case ${COMP_WORDS[latest_minus]} in%s
286 *) did_something=0;;
287 esac
288 fi
289 " (String.concat "" (List.map (fun (k,{params=l;stop=_}) -> stringify_completion (k,l)) l)) in
290 let default_completion = Printf.sprintf "
291 if [ $did_something -eq 0 ]; then
292 case ${cur} in
293 -*) COMPREPLY=($(compgen -W '%s' -- ${cur}));;
294 *) %s;;
295 esac
296 fi
297 " (String.concat " " (List.map fst l))
298 (stringify_simple_completion default) in
299 let epilogue = Printf.sprintf "\
300 }
301
302 complete -F _%s -o filenames %s
303 " one_name (String.concat " " names) in
304 prologue ^ check_stop ^ complete ^ default_completion ^ epilogue
305
306 let generate ?name ?names ?default args =
307 let completion = convert args in
308 let s = stringify ?name ?names ?default completion in
309 let c = open_out "bash_completion" in
310 output_string c s;
311 close_out c
312
313 let rec add_bash_completion ?name ?names ?default args =
314 let rec new_args =
315 ("--bash-completion",
316 Unit (fun () -> generate ?name ?names ?default new_args; exit 0),
317 " Dumps a bash completion in ./bash_completion") :: args in
318 new_args
319
d984e38 [fix] baseArg: wrong update of Arg.split with the new String.splice_c…
Valentin Gatien-Baron authored
320 let split s = String.slice_chars " ,;" s
Something went wrong with that request. Please try again.