source: project/release/4/getopt-long/getopt-long.scm @ 15622

Last change on this file since 15622 was 15622, checked in by Ivan Raikov, 10 years ago

initial import of getopt-long, a command-line parsing library

File size: 21.8 KB
Line 
1;;
2;; getopt-style command-line parser
3;;
4;; Author: Russ McManus (rewritten by Thien-Thi Nguyen)
5;;
6;; Ported to Chicken Scheme and extensively modified by Ivan Raikov.
7;;
8;; Copyright 2009 Ivan Raikov.
9;;
10;; Portions copyright (C) 1998, 2001, 2006 Free Software Foundation,
11;; Inc.
12;;
13;; This program is free software: you can redistribute it and/or
14;; modify it under the terms of the GNU Lesser General Public License
15;; as published by the Free Software Foundation, either version 3 of
16;; the License, or (at your option) any later version.
17;;
18;; This program is distributed in the hope that it will be useful, but
19;; WITHOUT ANY WARRANTY; without even the implied warranty of
20;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
21;; General Public License for more details.
22;;
23;; A full copy of the Lesser GPL license can be found at
24;; <http://www.gnu.org/licenses/>.
25;;
26
27;;; Commentary:
28
29;;; This module implements command line option parsing, in the spirit
30;;; of the GNU C library function `getopt_long'.  Both long and short
31;;; options are supported.
32;;;
33;;; The theory is that people should be able to constrain the set of
34;;; options they want to process using a grammar, rather than some
35;;; arbitrary structure.  The grammar makes the option descriptions
36;;; easy to read.
37;;;
38;;; `getopt-long' is a procedure for parsing command-line arguments in
39;;; a manner consistent with GNU programs.
40;;;
41;;; `usage' is a procedure that prints help strings about the
42;;; command-line arguments defined in a grammar.
43
44;;; (getopt-long ARGS GRAMMAR) Parse the arguments ARGS according to
45;;; the argument list grammar GRAMMAR.
46;;;
47;;; ARGS should be a list of strings.  Its first element should be the
48;;; name of the program; subsequent elements should be the arguments
49;;; that were passed to the program on the command line.  The
50;;; `program-arguments' procedure returns a list of this form.
51;;;
52;;; GRAMMAR is a list of the form:
53;;; ((OPTION-NAME [DOCSTRING]
54;;;               (PROPERTY VALUE) ...) ...)
55;;;
56;;; Each OPTION-NAME should be a symbol.  `getopt-long' will accept a
57;;; command-line option named `--OPTION-NAME'.
58;;;
59;;  If DOCSTRING is provided, it must be a either string a string
60;;  containing a brief description of the option.
61;;;
62;;; Each option can have the following (PROPERTY VALUE) pairs:
63;;;
64;;;   (single-char CHAR) --- Accept `-CHAR' as a single-character
65;;;             equivalent to `--OPTION'.  This is how to specify traditional
66;;;             Unix-style flags.
67;;;
68;;;   (required? BOOL) --- If BOOL is true, the option is required.
69;;;             getopt-long will raise an error if it is not found in ARGS.
70;;;
71;;;   (value FLAG [(PROPERTY VALUE) ...])
72;;;             --- If FLAG is #t, the option requires a value; if
73;;;             it is #f, it does not;
74;;;             if it is of the form (REQUIRED name) then the option requires
75;;;             and the name is used by the usage procedure
76;;;             if it is of the form (OPTIONAL name) the option may
77;;;             appear with or without a (named) value.
78;;;             
79;;;             In addition, the following properties can be defined
80;;;             for a value:
81;;;
82;;;            (predicate FUNC) ---
83;;;
84;;;                  If the option accepts a value, then getopt will
85;;;                  apply FUNC to the value, and throw an exception
86;;;                  if it returns #f.  FUNC should be a procedure
87;;;                  which accepts a string and returns a boolean
88;;;                  value; you may need to use quasiquotes to get it
89;;;                  into GRAMMAR.
90;;;
91;;;            (transformer FUNC) ---
92;;;
93;;;                  If the option accepts a value, then getopt will
94;;;                  apply FUNC to the string provided on the command
95;;;                  line, and put the resulting value in the list of
96;;;                  parsed options returned by getopt-long.
97;;;
98;;; The (PROPERTY VALUE) pairs may occur in any order, but each
99;;; property may occur only once.  By default, options do not have
100;;; single-character equivalents, are not required, and do not take
101;;; values.
102;;;
103;;; In ARGS, single-character options may be combined, in the usual
104;;; Unix fashion: ("-x" "-y") is equivalent to ("-xy").  If an option
105;;; accepts values, then it must be the last option in the
106;;; combination; the value is the next argument.  So, for example, using
107;;; the following grammar:
108;;;
109;;;      ((apples    (single-char #\a))
110;;;       (blimps    (single-char #\b) (value #t))
111;;;       (catalexis (single-char #\c) (value #t)))
112;;;
113;;; the following argument lists would be acceptable:
114;;;
115;;;    ("-a" "-b" "bang" "-c" "couth")     ("bang" and "couth" are the values
116;;;                                         for "blimps" and "catalexis")
117;;;    ("-ab" "bang" "-c" "couth")         (same)
118;;;    ("-ac" "couth" "-b" "bang")         (same)
119;;;    ("-abc" "couth" "bang")             (an error, since `-b' is not the
120;;;                                         last option in its combination)
121;;;
122;;; If an option's value is optional, then `getopt-long' decides
123;;; whether it has a value by looking at what follows it in ARGS.  If
124;;; the next element is does not appear to be an option itself, then
125;;; that element is the option's value.
126;;;
127;;; The value of a long option can appear as the next element in ARGS,
128;;; or it can follow the option name, separated by an `=' character.
129;;; Thus, using the same grammar as above, the following argument lists
130;;; are equivalent:
131;;;
132;;;   ("--apples" "Braeburn" "--blimps" "Goodyear")
133;;;   ("--apples=Braeburn" "--blimps" "Goodyear")
134;;;   ("--blimps" "Goodyear" "--apples=Braeburn")
135;;;
136;;; If the option "--" appears in ARGS, argument parsing stops there;
137;;; subsequent arguments are returned as ordinary arguments, even if
138;;; they resemble options.  So, in the argument list:
139;;;
140;;;         ("--apples" "Granny Smith" "--" "--blimp" "Goodyear")
141;;;
142;;; `getopt-long' will recognize the `apples' option as having the
143;;; value "Granny Smith", but it will not recognize the `blimp'
144;;; option; it will return the strings "--blimp" and "Goodyear" as
145;;; ordinary argument strings.
146;;;
147;;; The `getopt-long' function returns the parsed argument list as an
148;;; assocation list, mapping option names --- the symbols from GRAMMAR
149;;; --- onto their values, or #t if the option does not accept a value.
150;;; Unused options do not appear in the alist.
151;;;
152;;; All arguments that are not the value of any option are returned
153;;; as a list, associated with the empty list.
154;;;
155;;; `getopt-long' throws an exception if:
156;;; - it finds an unrecognized property in GRAMMAR
157;;; - the value of the `single-char' property is not a character,
158;;;   or a single-character string/symbol
159;;; - it finds an unrecognized option in ARGS
160;;; - a required option is omitted
161;;; - an option that requires an argument doesn't get one
162;;; - an option that doesn't accept an argument does get one (this can
163;;;   only happen using the long option `--opt=value' syntax)
164;;; - an option predicate fails
165;;;
166;;; For an example, see file tests/run.scm.
167
168
169
170(module getopt-long
171
172        (getopt-long width separator indent usage make-option-dispatch)
173
174        (import scheme chicken)
175       
176        (require-extension data-structures srfi-1 srfi-13 srfi-14 
177                           defstruct matchable )
178
179
180(define (lookup-def k lst . rest)
181  (let-optionals rest ((default #f))
182      (let ((kv (assoc k lst)))
183        (if (not kv) default
184            (match kv ((k v) v) (else (cdr kv)))))))
185
186(defstruct value-policy name predicate transformer
187  optional? default )
188
189(defstruct option-spec name value required? 
190  single-char docstring )
191
192;;
193;; We don't auto-format the left column (the option keys) based on the
194;; length of the longest option, but you can override it manually.
195;;
196(define width (make-parameter 25))
197
198;; The separator used between options.  Default: ", "
199
200(define separator (make-parameter ", "))
201(define indent (make-parameter 1))
202
203(define (spaces n)
204  (let loop ((ls '()) (n n))
205    (if (<= n 0)
206        (list->string ls)
207        (loop (cons #\space ls)
208              (- n 1)))))
209
210;; Join together option names in spec with commas, and append the
211;; argument type and name
212
213(define-record-printer (option-spec x out)
214  (let* ((name          (option-spec-name x))
215         (value-policy  (option-spec-value x))
216         (required?     (option-spec-required? x))
217         (single-char   (option-spec-single-char x))
218         (docstring     (option-spec-docstring x))
219         (long-option   (and (not (make-single-char name))
220                             (string-append "--" (->string name))))
221         (short-option  (or (and single-char 
222                                 (list->string (list #\- single-char)))
223                            (make-single-char name)))
224         (option-lst    (cond ((and short-option long-option)
225                               (list long-option (separator) short-option))
226                              (long-option
227                               (list long-option))
228                              (else (list short-option))))
229         (option-lst
230          (cond
231           (value-policy 
232            (if (value-policy-optional? value-policy) 
233                (cons* "]" (->string (value-policy-name value-policy) )
234                       "[" "=" option-lst)
235                (cons* (->string (value-policy-name value-policy))
236                       "=" 
237                       option-lst)))
238           (else        option-lst)))
239
240         (option-string (string-concatenate (reverse option-lst))))
241
242    (display
243     (string-append (spaces (indent))
244                    (string-pad-right option-string (width))
245                    docstring
246                    "\n")
247     out)))
248
249;; Generate a formatted list of options from OPTION-LIST, and return a
250;; string suitable for embedding into help text.  The single string
251;; consists of multiple lines, with a newline at the end of each line.
252;; Thus, a typical use would be (print (usage opts)).
253(define (usage opts) 
254  (let ((specs (map parse-option-spec opts)))
255    (apply string-append (map ->string specs))))
256
257(define update-option-spec
258  (lambda (x . key/values)
259    (apply
260     (lambda (#!key
261              (name           (option-spec-name x)) 
262              (required?      (option-spec-required? x))
263              (single-char    (option-spec-single-char x))
264              (value          (option-spec-value x))
265              (docstring      (option-spec-docstring x))
266              )
267          (make-option-spec 
268           name:        name
269           required?:   required?
270           single-char: single-char
271           value:       value
272           docstring:   docstring
273           ))
274     key/values)))
275
276(define (make-predicate pred)
277  (lambda (name val)
278    (or (not val)
279        (pred val)
280        (error "option predicate failed:" name))))
281
282(define (make-single-char x)
283  (let ((lst (string->list (->string x))))
284    (and (null? (cdr lst))
285         (car lst))))
286   
287
288(define (parse-option-spec desc)
289 
290  (let* ((name         (->string (car desc)))
291         (single-char  (make-single-char name))
292         (spec
293          (make-option-spec 
294           name:        (string->symbol name)
295           required?:   #f
296           single-char: single-char
297           value:       #f
298           docstring:   ""
299           )))
300
301    (fold
302     (lambda (desc-elem spec)
303       (cond ((string? desc-elem)
304              (update-option-spec spec docstring: desc-elem))
305
306             (else
307              (let ((given (lambda () (cdr desc-elem))))
308
309                (case (car desc-elem)
310                 
311                  ((required?)
312                   (update-option-spec spec required?: (car (given))))
313                 
314                  ((value)
315                   (let ((value-policy
316                          (match (given)
317
318                                 ((((and flag (or 'required 'optional))
319                                    (and name (or (? symbol?) (? string?)))) . rst)
320                                  (let ((predicate 
321                                         (cond ((lookup-def 'predicate rst) =>
322                                                make-predicate)
323                                               (else
324                                                (lambda x (identity x)))))
325
326                                        (transformer 
327                                         (or (lookup-def 'transformer rst)
328                                             identity))
329
330                                        (default (lookup-def 'default rst))
331                                        )
332
333                                    (make-value-policy 
334                                     name: name
335                                     predicate: predicate
336                                     transformer: transformer
337                                     optional?: (equal? flag 'optional)
338                                     default:  (and default 
339                                                    (->string default))
340                                     
341                                     )))
342
343                                 ((#t) (make-value-policy 
344                                      name: 'ARG
345                                      predicate: (lambda x (identity x))
346                                      transformer: identity
347                                      optional?: #f
348                                      default: #f))
349
350                                 ((#f) #f)
351
352                                 (else (error "invalid value specification "
353                                              (given)))
354
355                                 )))
356                     (update-option-spec spec value: value-policy)))
357                 
358                  ((single-char)
359                   (cond
360                    ((make-single-char (car (given))) =>
361                     (lambda (c)
362                       (update-option-spec spec single-char: c)))
363                    (else
364                     (error "`single-char' value must be a single character, string, or symbol"))))
365
366                  (else
367                   (error "invalid getopt-long option property:"
368                          (car desc-elem))))))))
369     spec (cdr desc))
370    ))
371
372
373
374(define (split-argument-list argument-list)
375  ;; Scan ARGUMENT-LIST for "--" and return (BEFORE-LS . AFTER-LS).
376  ;; Discard the "--".  If no "--" is found, AFTER-LS is empty.
377  (let loop ((yes '()) (no argument-list))
378    (cond ((null? no)               (cons (reverse yes) no))
379          ((string=? "--" (car no)) (cons (reverse yes) (cdr no)))
380          (else (loop (cons (car no) yes) (cdr no))))))
381
382
383(define (check-long-option str)
384  (string=? (substring str 0 2) "--"))
385
386(define (check-short-option str)
387  (string=? (substring str 0 1) "-"))
388
389(define long-option-name-cs 
390  (char-set-union char-set:letter
391                  (char-set #\-)))
392
393(define (long-option-name lst)
394  (let loop ((lst lst)  (ax (list)))
395    (cond ((null? lst)  (list (list->string (reverse ax)) lst))
396          ((and (char? (car lst))
397                (char-set-contains? long-option-name-cs 
398                                   (car lst)) 
399                (car lst)) =>
400                (lambda (c)
401                  (loop (cdr lst) (cons c ax))))
402
403          ((char=? (car lst) #\=)
404           (list (list->string (reverse ax)) (cdr lst)))
405
406          (else (error 'long-option-name 
407                       "invalid list " lst)))))
408
409(define long-option-value-cs 
410  (char-set-union char-set:letter+digit 
411                  char-set:punctuation))
412
413(define (long-option-value lst)
414  (let loop ((lst lst)  (ax (list)))
415    (cond ((null? lst)  (list (list->string (reverse ax)) lst))
416          ((and (char? (car lst))
417                (char-set-contains? long-option-value-cs 
418                                   (car lst)) 
419                (car lst)) =>
420                (lambda (c)
421                  (loop (cdr lst) (cons c ax))))
422
423          (else (error 'long-option-value 
424                       "invalid list " lst)))))
425
426
427(define (long-option? specs a next)
428  (let ((l (string->list a)))
429    (match l
430           ((#\- #\-  . rst)
431            (match-let* (((n nrst)  (long-option-name rst))
432                         ((v ())    (long-option-value nrst))
433                         ((next v)
434                          (or (and v (list next v))
435                              (and (not (check-long-option (car next)))
436                                   (not (check-short-option (car next)))
437                                   (list (cdr next) (car next))))))
438              (cond ((alist-ref (string->symbol n) (car specs)) =>
439                     (lambda (spec)
440                       (cond
441
442                        ((and v (option-spec-value spec)) =>
443                         (lambda (value-policy)
444                           (or
445                            (and ((or (value-policy-predicate value-policy)
446                                      (lambda x (identity x))) n v)
447                                 (let ((transformer
448                                        (or (value-policy-transformer value-policy)
449                                            identity)))
450                                 (list next (cons n (transformer v)))))
451                            (error 'long-option? 
452                                   "predicate error on option value " n))))
453
454                        ((and v (not (option-spec-value spec)))
455                         (error 'long-option? 
456                                "superfluous argument given to option " n))
457                       
458                        ((and (not v) (option-spec-value spec))
459                         (error 'long-option? "option requires value " n))
460                       
461                        ((and (not v) (value-policy-optional? 
462                                       (option-spec-value spec)))
463                         (list next (cons n #t)))
464                       
465                        (else
466                         (list next (cons n #t)))
467                             
468                       )))
469                    (else
470                     (error 'long-option? "unknown option " n)))))
471           (else #f))))
472
473
474(define short-option-name-cs 
475  char-set:letter)
476
477(define (short-option-names lst)
478  (let loop ((lst lst)  (ax (list)))
479    (cond ((null? lst)  (list ax lst))
480
481          ((and (char? (car lst))
482                (char-set-contains? short-option-name-cs 
483                                   (car lst)) 
484                (car lst)) =>
485                (lambda (c)
486                  (loop (cdr lst) (cons c ax))))
487
488          (else (error 'long-option-name 
489                       "invalid list " lst)))))
490
491(define (short-options? specs a next)
492  (let ((l (string->list a)))
493    (match l
494           ((#\-  . rst)
495            (match-let ((((n1 . ns) ())  (short-option-names rst)))
496              (match-let
497               ;; special case: check if the last single-letter option
498               ;; has an argument
499               (((next opt1)
500                 (cond
501                  ((alist-ref n1 (cadr specs) ) =>
502                   (lambda (spec)
503                     (let ((name (->string (option-spec-name spec))))
504
505                       (cond
506                        ((option-spec-value spec) =>
507                         (lambda (value-policy)
508                           (let ((v (and (pair? next)
509                                         (not (check-long-option (car next) ))
510                                         (not (check-short-option (car next) ))
511                                         (car next))))
512                             (if (not v) 
513                                 (error 'short-options? 
514                                        "option requires value: " name))
515                             
516                             (or
517                              (and ((or (value-policy-predicate value-policy) 
518                                        (lambda x (identity x))) name v)
519                                   (let ((transformer
520                                          (or (value-policy-transformer value-policy) 
521                                              identity)))
522                                     (list (cdr next) (cons name (transformer v)))))
523                              (error 'short-options? 
524                                     "predicate error on option value " 
525                                     name)))))
526                                 
527                        (else
528                         (list next (cons name #t)))))))
529                  (else
530                   (error 'short-options? "unknown option " n1)))))
531               (list next 
532                     (cons opt1 
533                           (map (lambda (n)
534                                  (cond
535                                   ((alist-ref n (cadr specs) ) =>
536                                    (lambda (spec)
537                                      (cond
538                                       ((option-spec-value spec)
539                                        (error 'short-options?
540                                               "option requires value: " n))
541                                       
542                                       (else
543                                        (cons (->string (option-spec-name spec)) #t)))))
544                                   
545                                   (else
546                                    (error 'short-options? 
547                                           "unknown option " n))))
548                                ns)))))
549              )
550           (else #f))))
551           
552 
553 
554
555(define (process-options specs argument-ls)
556  ;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC).
557  ;; FOUND is an unordered list of option specs for found options, while ETC
558  ;; is an order-maintained list of elements in ARGUMENT-LS that are neither
559  ;; options nor their values.
560  (let loop ((ls argument-ls)  (found (list)) (etc (list)))
561
562    (if (null? ls) (cons found (reverse etc))
563
564        (let ((arg (car ls)) (rest (cdr ls)))
565          (cond ((long-option? specs arg rest) =>
566                 (lambda (kont)
567                   (loop (car kont) (cons (cadr kont) found) etc)))
568               
569                ((short-options? specs arg rest) =>
570                 (lambda (kont)
571                   (loop (car kont) (append (cadr kont) found) etc)))
572
573                (else
574                 (loop (cdr ls) found (cons (car ls) etc))))))))
575                                 
576
577
578(define (getopt-long program-arguments option-desc-list)
579;;   Process options, handling both long and short options, similar to
580;; the glibc function 'getopt_long'.  PROGRAM-ARGUMENTS should be a value
581;; similar to what (program-arguments) returns.  OPTION-DESC-LIST is a
582;; list of option descriptions.  Each option description must satisfy the
583;; following grammar:
584;;
585;;     <option-spec>           :: (<name> . <attribute-ls>)
586;;     <attribute-ls>          :: (<attribute> . <attribute-ls>)
587;;                                | ()
588;;     <attribute>             :: <required-attribute>
589;;                                | <arg-required-attribute>
590;;                                | <single-char-attribute>
591;;                                | <value-attribute>
592;;     <required-attribute>    :: (required? <boolean>)
593;;     <single-char-attribute> :: (single-char <char>)
594;;     <value-attribute>       :: (value #t)
595;;                                (value #f)
596;;                                (value (required <name>))
597;;                                (value (optional <name>))
598;;                                (<value-attribute>
599;;                                 <predicate-attribute>)
600;;     <predicate-attribute>   :: (predicate <1-ary-function>)
601;;
602;;     The procedure returns an alist of option names and values.
603;; Each option name is a symbol.  The option value will be '#t' if no
604;; value was specified.  There is a special item in the returned alist
605;; with a key @: the list of arguments that are not options or option
606;; values.
607;;
608;;     By default, options are not required, and option values are not
609;; required.  By default, single character equivalents are not
610;; supported; if you want to allow the user to use single character
611;; options, you need to add a `single-char' clause to the option
612;; description.
613
614  (let* ((specifications (map parse-option-spec option-desc-list))
615         (spec-long      (map (lambda (spec)
616                                (cons (option-spec-name spec) spec))
617                              specifications))
618         (spec-short     (filter-map
619                          (lambda (spec)
620                            (and (option-spec-single-char spec)
621                                 (cons (option-spec-single-char spec) 
622                                       spec)))
623                          specifications))
624         (pair           (split-argument-list program-arguments))
625         (split-ls       (car pair))
626         (non-split-ls   (cdr pair))
627         (found/etc      (process-options
628                          (list spec-long spec-short) split-ls))
629         (found          (car found/etc))
630         (rest-ls        (append (cdr found/etc) non-split-ls)))
631    (for-each (lambda (spec)
632                (let ((name (->string (option-spec-name spec))))
633
634                  (and (option-spec-required? spec)
635                       (or (assoc name found )
636                           (error "option must be specified:" name)))
637
638                  (and (assoc name found)
639                       (and (option-spec-value spec)
640                            (not (value-policy-optional?
641                                  (option-spec-value spec))))
642                       (or (cdr (assoc name found))
643                           (error "option must be specified with argument:"
644                                  name)))))
645              specifications)
646
647    (cons (cons '@ rest-ls) found)))
648
649(define (make-option-dispatch opts options-desc-list)
650  (let* ((specifications (map parse-option-spec options-desc-list))
651         (defaults
652           (filter-map
653            (lambda (spec) 
654              (let* ((name (option-spec-name spec))
655                     (value-policy (option-spec-value spec))
656                     (default (and value-policy 
657                                   (value-policy-default value-policy)))
658                     )
659                (cond ((and value-policy 
660                            (value-policy-predicate value-policy)) =>
661                            (lambda (pred)
662                              (or (pred name default) 
663                                  (error 'make-option-dispatch
664                                         "predicate error in default value: "
665                                         default)))))
666                (let ((transformer
667                       (or (and value-policy 
668                                (value-policy-transformer value-policy))
669                           identity)))
670                  (and default (list name (transformer default))))
671                ))
672            specifications)))
673
674    (lambda (name)
675      (case name 
676        ((@)  (alist-ref '@ opts))
677        (else
678         (let ((v (or (alist-ref (->string name) (cdr opts) string=?)
679                      (lookup-def name defaults))))
680           v)
681         )))
682    ))
683           
684         
685
686)
687;;; getopt-long.scm ends here
Note: See TracBrowser for help on using the repository browser.