source: project/release/5/args/trunk/args.scm @ 36399

Last change on this file since 36399 was 36399, checked in by kooda, 11 months ago

Port the args egg to CHICKEN 5

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