source: project/release/4/args/trunk/args.scm

Last change on this file was 32428, checked in by Jim Ursetto, 4 years ago

args: option body should occur after arg value is normalized

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