1 | |
---|
2 | ;;; macro: (args:make-option (OPTION-NAME ...) ARG-DATA [BODY]) |
---|
3 | |
---|
4 | (include "srfi-37.scm") |
---|
5 | |
---|
6 | ;; from srfi-1 |
---|
7 | |
---|
8 | (define (find pred list) |
---|
9 | (cond ((find-tail pred list) => car) |
---|
10 | (else #f))) |
---|
11 | |
---|
12 | (define (find-tail pred list) |
---|
13 | ; (check-arg procedure? pred find-tail) |
---|
14 | (let lp ((list list)) |
---|
15 | (and (not (null-list? list)) |
---|
16 | (if (pred (car list)) list |
---|
17 | (lp (cdr list)))))) |
---|
18 | |
---|
19 | ;; from srfi-13 |
---|
20 | |
---|
21 | (define (%string-copy! to tstart from fstart fend) |
---|
22 | (##core#inline "C_substring_copy" from to fstart fend tstart)) |
---|
23 | |
---|
24 | (define (%substring/shared s start end) |
---|
25 | (if (and (zero? start) (= end (string-length s))) s |
---|
26 | (##sys#substring s start end))) |
---|
27 | |
---|
28 | (define (string-pad-right s n . char+start+end) |
---|
29 | (##sys#check-exact n 'string-pad-right) |
---|
30 | (let-optionals* char+start+end ((char #\space) rest) ; (char? char)) rest) |
---|
31 | (let-string-start+end (start end) string-pad-right s rest |
---|
32 | (let ((len (- end start))) |
---|
33 | (if (<= n len) |
---|
34 | (%substring/shared s start (+ start n)) |
---|
35 | (let ((ans (make-string n char))) |
---|
36 | (%string-copy! ans 0 s start end) |
---|
37 | ans)))))) |
---|
38 | |
---|
39 | |
---|
40 | |
---|
41 | ;; OPTION-NAME ... is a sequence of short or long option names. They must be literal |
---|
42 | ;; symbols; single-character symbols become short options, and longer symbols become |
---|
43 | ;; long options. So (args:make-option (c cookie) <...>) specifies a short option -c |
---|
44 | ;; and long option --cookie. Underneath, (c cookie) becomes '(#\c "cookie"), as |
---|
45 | ;; expected by SRFI 37's OPTION. |
---|
46 | ;; |
---|
47 | ;; ARG-DATA is either a pair (ARG-TYPE ARG-NAME) or a plain keyword ARG-TYPE. |
---|
48 | ;; ARG-TYPE is a keyword that specifies whether the option takes an argument: |
---|
49 | ;; #:required Argument is required |
---|
50 | ;; #:optional Argument is optional |
---|
51 | ;; #:none Does not take an argument (actually, any other value than |
---|
52 | ;; #:required or #:optional is interpreted as #:none) |
---|
53 | ;; ARG-NAME, if provided, is a string specifying the name of the argument. |
---|
54 | ;; This name is used in the help text produced by args:usage. |
---|
55 | ;; |
---|
56 | ;; BODY is an optional sequence of statements executed when this option is encountered. |
---|
57 | ;; Behind the scenes, BODY is wrapped in code which adds the current option and its |
---|
58 | ;; argument to the final options alist. So, simply leave BODY blank and options |
---|
59 | ;; will be collected for you. BODY is an option-processor as defined in SRFI 37, |
---|
60 | ;; and has access to the variables OPT (the current #<option>), NAME (the option name) |
---|
61 | ;; and ARG (argument value or #f). |
---|
62 | |
---|
63 | (define-macro (args:make-option names arg-data docstring . body) |
---|
64 | (let* ((srfi37-names (map (lambda (name) |
---|
65 | (let ((str (symbol->string name))) |
---|
66 | (if (= (string-length str) 1) |
---|
67 | (string-ref str 0) |
---|
68 | str))) |
---|
69 | names)) |
---|
70 | (arg-name (if (pair? arg-data) (cadr arg-data) "ARG")) |
---|
71 | (arg-type (if (pair? arg-data) (car arg-data) arg-data))) |
---|
72 | `(make-args:option |
---|
73 | (option ',srfi37-names |
---|
74 | ,(eq? arg-type #:required) |
---|
75 | ,(eq? arg-type #:optional) |
---|
76 | (lambda (opt name arg options operands) |
---|
77 | (if (and (not arg) (eq? ,arg-type #:required)) |
---|
78 | (begin |
---|
79 | (fprintf (current-error-port) |
---|
80 | "~A: option ~A requires an argument\n" |
---|
81 | (car (argv)) name) |
---|
82 | (values options operands)) |
---|
83 | (begin |
---|
84 | ,@body |
---|
85 | (values (append (map (lambda (n) (cons n arg)) |
---|
86 | ',names) |
---|
87 | options) |
---|
88 | operands))))) |
---|
89 | ;;(values (cons (cons name arg) options) operands))) |
---|
90 | ,arg-name |
---|
91 | ,docstring))) |
---|
92 | |
---|
93 | ;;; macro: (args:make-operand-proc [BODY]) |
---|
94 | |
---|
95 | ;; Return a procedure suitable for using as an operand procedure |
---|
96 | ;; in args:parse. Provides the arguments OPERAND, OPTIONS, and OPERANDS |
---|
97 | ;; to the BODY; where OPERAND is the current operand (as in args-fold) |
---|
98 | ;; and OPTIONS and OPERANDS are SEEDS (as in args-fold) and should not be modified. |
---|
99 | ;; Also wraps BODY in code that adds the operand to the final operand list (seed). |
---|
100 | (define-macro (args:make-operand-proc . body) |
---|
101 | `(lambda (operand options operands) |
---|
102 | ,@body |
---|
103 | (values options (cons operand operands)))) |
---|
104 | |
---|
105 | |
---|
106 | ;; This extension provides a wrapper around SRFI 37 (args-fold). The main |
---|
107 | ;; goal is to let the user parse command-line arguments without having to |
---|
108 | ;; write a lot of similar support code every time. |
---|
109 | ;; |
---|
110 | ;; By default, options and operands (non-options) are collected into two lists |
---|
111 | ;; and returned by the parser, and unrecognized options complain and display |
---|
112 | ;; help. Therefore, it is very possible not to write any option-procs, |
---|
113 | ;; operand-procs, or unrecognized-procs as required by SRFI 37. However, the |
---|
114 | ;; capability to customize is there should you need it. |
---|
115 | ;; |
---|
116 | ;; Additionally, the help text for your options can be generated for |
---|
117 | ;; you, so your options and usage information don't get out of sync. |
---|
118 | |
---|
119 | ;; BUGS: The name 'args:make-option' is verbose. |
---|
120 | |
---|
121 | ;;; macro: (args:make-option (OPTION-NAME ...) ARG-TYPE [BODY]) |
---|
122 | ;; Make an args:option record, suitable for passing to args:parse. |
---|
123 | ;; |
---|
124 | ;; OPTION-NAME ... is a sequence of short or long option names. They must be literal |
---|
125 | ;; symbols; single-character symbols become short options, and longer symbols become |
---|
126 | ;; long options. So (args:make-option (c cookie) <...>) specifies a short option -c |
---|
127 | ;; and long option --cookie. Underneath, (c cookie) becomes '(#\c "cookie"), as |
---|
128 | ;; expected by SRFI 37's OPTION. |
---|
129 | ;; |
---|
130 | ;; ARG-DATA is either a pair (ARG-TYPE ARG-NAME) or a plain keyword ARG-TYPE. |
---|
131 | ;; ARG-TYPE is a keyword that specifies whether the option takes an argument: |
---|
132 | ;; #:required Argument is required |
---|
133 | ;; #:optional Argument is optional |
---|
134 | ;; #:none Does not take an argument (actually, any other value than |
---|
135 | ;; #:required or #:optional is interpreted as #:none) |
---|
136 | ;; ARG-NAME, if provided, is a string specifying the name of the argument. |
---|
137 | ;; This name is used in the help text produced by args:usage. |
---|
138 | ;; |
---|
139 | ;; BODY is an optional sequence of statements executed when this option is encountered. |
---|
140 | ;; Behind the scenes, BODY is wrapped in code which adds the current option and its |
---|
141 | ;; argument to the final options alist. So, simply leave BODY blank and options |
---|
142 | ;; will be collected for you. BODY is an option-processor as defined in SRFI 37, |
---|
143 | ;; and has access to the variables OPT (the current #<option>), NAME (the option name) |
---|
144 | ;; and ARG (argument value or #f). |
---|
145 | |
---|
146 | (define-record args:option option arg-name docstring) |
---|
147 | |
---|
148 | ;;; procedure: (args:parse ARGS OPTIONS-LIST [OPTIONALS]) |
---|
149 | ;; [chicken-specific dependencies: FPRINTF; GET-KEYWORD; ARGV] |
---|
150 | |
---|
151 | ;; Parse ARGS, a list of command-line arguments given as strings, |
---|
152 | ;; and return two values: an alist of option names (symbols) and their values, |
---|
153 | ;; and a list of operands (non-option arguments). |
---|
154 | |
---|
155 | ;; Operands are returned in order, but options are returned in reverse order. |
---|
156 | ;; Duplicate options are retained in the options alist, so this lets ASSQ |
---|
157 | ;; find the -last- occurrence of any duplicate option on the command line. |
---|
158 | ;; A (name . value) pair is added for each alias of every option found, |
---|
159 | ;; so any alias is a valid lookup key. |
---|
160 | |
---|
161 | ;; OPTIONS-LIST is a list of accepted options, each created by |
---|
162 | ;; args:make-option. |
---|
163 | ;; |
---|
164 | ;; OPTIONALS is an optional sequence of keywords and values: |
---|
165 | ;; #:operand-proc PROCEDURE -- calls PROCEDURE for each operand |
---|
166 | ;; with arguments OPERAND OPTIONS OPERANDS |
---|
167 | ;; #:unrecognized-proc PROCEDURE -- calls PROCEDURE for each unrecognized option |
---|
168 | ;; with arguments OPTION NAME ARG OPTIONS OPERANDS |
---|
169 | ;; The default operand-proc is a no-op, and the default unrecognized-proc |
---|
170 | ;; issues an error message and calls the help option's processor. |
---|
171 | ;; See the args-fold documentation for usage information and an explanation |
---|
172 | ;; of the procedure arguments; OPTIONS and OPERANDS are seed values. |
---|
173 | |
---|
174 | ;; Two prefabricated unrecognized-procs are provided: |
---|
175 | ;; args:ignore-unrecognized-options |
---|
176 | ;; args:accept-unrecognized-options |
---|
177 | |
---|
178 | (define (find-named-option name opts) |
---|
179 | (find (lambda (o) |
---|
180 | (member name (option-names (args:option-option o)))) |
---|
181 | opts)) |
---|
182 | |
---|
183 | (define (find-help-option opts) |
---|
184 | (ormap (lambda (n) (find-named-option n opts)) |
---|
185 | (args:help-options))) |
---|
186 | |
---|
187 | ;;; parameter: args:help-options |
---|
188 | ;; List of option names (strings or single characters, as in SRFI 37) |
---|
189 | ;; to be considered 'help' options, in order of preference. args:parse |
---|
190 | ;; uses this to select a help option from the option list it is passed. |
---|
191 | ;; This is currently used only for unrecognized options, for which the |
---|
192 | ;; help option is automatically invoked. |
---|
193 | |
---|
194 | (define args:help-options |
---|
195 | (make-parameter '("help" #\h #\?))) |
---|
196 | |
---|
197 | (define (args:parse args options-list . optionals) |
---|
198 | (let ((help-option (find-help-option options-list))) |
---|
199 | (receive (options operands) |
---|
200 | (args-fold args |
---|
201 | (map (lambda (x) (args:option-option x)) |
---|
202 | options-list) |
---|
203 | (get-keyword #:unrecognized-proc optionals |
---|
204 | (lambda () ; thunk |
---|
205 | ;; Default: print unrecognized option and execute help procedure, |
---|
206 | ;; if a help option was provided. |
---|
207 | (lambda (opt name arg options operands) |
---|
208 | (fprintf (current-error-port) |
---|
209 | "~A: unrecognized option: ~A\n" |
---|
210 | (car (argv)) name) |
---|
211 | (if help-option |
---|
212 | ((option-processor (args:option-option help-option)) |
---|
213 | opt name arg options operands) |
---|
214 | (exit 1))))) |
---|
215 | ;; modify the operands list for operands |
---|
216 | (get-keyword #:operand-proc optionals |
---|
217 | (lambda () (args:make-operand-proc))) ;; default |
---|
218 | '() ;; seed 1: options alist |
---|
219 | '()) ;; seed 2: operands list |
---|
220 | (values options (reverse operands))))) |
---|
221 | |
---|
222 | ;;; Prefabbed unrecognized option procedures |
---|
223 | ;; Suitable for use as the #:unrecognized-proc in args:parse. |
---|
224 | |
---|
225 | ;; Silently ignore unrecognized options, and omit from the options alist. |
---|
226 | (define args:ignore-unrecognized-options |
---|
227 | (lambda (o n x options operands) |
---|
228 | (values options operands))) |
---|
229 | |
---|
230 | ;; Silently add unrecognized options to the options alist. |
---|
231 | (define args:accept-unrecognized-options |
---|
232 | (lambda (o n x options operands) |
---|
233 | (values (cons (cons (string->symbol (if (char? n) (string n) n)) |
---|
234 | x) |
---|
235 | options) |
---|
236 | operands))) |
---|
237 | |
---|
238 | ;;; Usage handling |
---|
239 | |
---|
240 | ;; Change #\c => "-c" and "cookie" to "--cookie". |
---|
241 | (define (dashify x) |
---|
242 | (if (char? x) |
---|
243 | (string #\- x) |
---|
244 | (string-append "--" x))) |
---|
245 | |
---|
246 | ;; O is an args:option |
---|
247 | ;; Join together option names in O with commas, and append the |
---|
248 | ;; argument type and name |
---|
249 | (define (spaces n) |
---|
250 | (let loop ((ls '()) (n n)) |
---|
251 | (if (<= n 0) |
---|
252 | (list->string ls) |
---|
253 | (loop (cons #\space ls) |
---|
254 | (- n 1))))) |
---|
255 | |
---|
256 | (define (commify o) ;; more at home in Stalin? |
---|
257 | (let ((arg-type (lambda (args:o o-name) |
---|
258 | (let* ((arg-name (args:option-arg-name args:o)) |
---|
259 | (o (args:option-option args:o))) |
---|
260 | (cond ((option-required-arg? o) |
---|
261 | (string-append (if (char? o-name) |
---|
262 | " " "=") |
---|
263 | arg-name)) |
---|
264 | ((option-optional-arg? o) |
---|
265 | (string-append (if (char? o-name) |
---|
266 | " [" "[=") |
---|
267 | arg-name "]")) |
---|
268 | (else "")))))) |
---|
269 | |
---|
270 | (let loop ((accum #f) |
---|
271 | (names (option-names (args:option-option o)))) |
---|
272 | (if (null? names) |
---|
273 | accum |
---|
274 | (let* ((name (car names)) |
---|
275 | (may-be-arg |
---|
276 | (if (null? (cdr names)) |
---|
277 | (arg-type o name) |
---|
278 | ""))) |
---|
279 | (loop (string-append (or accum |
---|
280 | ;; Must deal with first one specially |
---|
281 | (if (string? name) |
---|
282 | (spaces (+ 2 (string-length (args:separator)))) |
---|
283 | "")) |
---|
284 | (if accum (args:separator) "") |
---|
285 | (dashify name) may-be-arg) |
---|
286 | (cdr names))))))) |
---|
287 | |
---|
288 | ;;; parameter: args:width |
---|
289 | ;; We don't auto-format the left column (the option keys) based on the length of the longest |
---|
290 | ;; option, but you can override it manually. |
---|
291 | ;; |
---|
292 | ;; Example: (parameterize ((args:width 40)) (args:usage opts)) |
---|
293 | (define args:width (make-parameter 25)) |
---|
294 | ;;; parameter: args:separator |
---|
295 | ;; The separator used between options. Default: ", " |
---|
296 | ;; Example: (parameterize ((args:separator " ")) (args:usage opts)) |
---|
297 | (define args:separator (make-parameter ", ")) |
---|
298 | (define args:indent (make-parameter 1)) |
---|
299 | |
---|
300 | ;; O is an args:option |
---|
301 | (define (usage-line o) |
---|
302 | (let ((option-string (commify o))) |
---|
303 | (string-append (spaces (args:indent)) |
---|
304 | (string-pad-right option-string (args:width)) |
---|
305 | (args:option-docstring o) "\n"))) |
---|
306 | |
---|
307 | ;;; procedure: (args:usage OPTION-LIST) |
---|
308 | ;; Generate a formatted list of options from OPTION-LIST, |
---|
309 | ;; and return a string suitable for embedding into help text. |
---|
310 | ;; The single string consists of multiple lines, with a newline |
---|
311 | ;; at the end of each line. Thus, a typical use would be |
---|
312 | ;; (print (args:usage opts)). |
---|
313 | (define (args:usage opts) |
---|
314 | (apply string-append (map usage-line opts))) |
---|