source: project/release/3/cmk/args.scm @ 12843

Last change on this file since 12843 was 12843, checked in by Ivan Raikov, 12 years ago

Added initial version of cmk.

File size: 13.4 KB
Line 
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)))
Note: See TracBrowser for help on using the repository browser.