Commit | Line | Data |
---|---|---|
1959fb04 LC |
1 | ;;; srfi-37.scm --- args-fold |
2 | ||
3 | ;; Copyright (C) 2007, 2008, 2013 Free Software Foundation, Inc. | |
4 | ;; | |
5 | ;; This library is free software; you can redistribute it and/or | |
6 | ;; modify it under the terms of the GNU Lesser General Public | |
7 | ;; License as published by the Free Software Foundation; either | |
8 | ;; version 3 of the License, or (at your option) any later version. | |
9 | ;; | |
10 | ;; This library is distributed in the hope that it will be useful, | |
11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;; Lesser General Public License for more details. | |
14 | ;; | |
15 | ;; You should have received a copy of the GNU Lesser General Public | |
16 | ;; License along with this library; if not, write to the Free Software | |
17 | ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
18 | ||
19 | \f | |
20 | ;;; Commentary: | |
21 | ;; | |
22 | ;; To use this module with Guile, use (cdr (program-arguments)) as | |
23 | ;; the ARGS argument to `args-fold'. Here is a short example: | |
24 | ;; | |
25 | ;; (args-fold (cdr (program-arguments)) | |
26 | ;; (let ((display-and-exit-proc | |
27 | ;; (lambda (msg) | |
28 | ;; (lambda (opt name arg) | |
29 | ;; (display msg) (quit) (values))))) | |
30 | ;; (list (option '(#\v "version") #f #f | |
31 | ;; (display-and-exit-proc "Foo version 42.0\n")) | |
32 | ;; (option '(#\h "help") #f #f | |
33 | ;; (display-and-exit-proc | |
34 | ;; "Usage: foo scheme-file ...")))) | |
35 | ;; (lambda (opt name arg) | |
36 | ;; (error "Unrecognized option `~A'" name)) | |
37 | ;; (lambda (op) (load op) (values))) | |
38 | ;; | |
39 | ;;; Code: | |
40 | ||
41 | \f | |
42 | ;;;; Module definition & exports | |
43 | (define-module (srfi srfi-37) | |
44 | #:use-module (srfi srfi-9) | |
45 | #:export (option option-names option-required-arg? | |
46 | option-optional-arg? option-processor | |
47 | args-fold)) | |
48 | ||
49 | (cond-expand-provide (current-module) '(srfi-37)) | |
50 | \f | |
51 | ;;;; args-fold and periphery procedures | |
52 | ||
53 | ;;; An option as answered by `option'. `names' is a list of | |
54 | ;;; characters and strings, representing associated short-options and | |
55 | ;;; long-options respectively that should use this option's | |
56 | ;;; `processor' in an `args-fold' call. | |
57 | ;;; | |
58 | ;;; `required-arg?' and `optional-arg?' are mutually exclusive | |
59 | ;;; booleans and indicate whether an argument must be or may be | |
60 | ;;; provided. Besides the obvious, this affects semantics of | |
61 | ;;; short-options, as short-options with a required or optional | |
62 | ;;; argument cannot be followed by other short options in the same | |
63 | ;;; program-arguments string, as they will be interpreted collectively | |
64 | ;;; as the option's argument. | |
65 | ;;; | |
66 | ;;; `processor' is called when this option is encountered. It should | |
67 | ;;; accept the containing option, the element of `names' (by `equal?') | |
68 | ;;; encountered, the option's argument (or #f if none), and the seeds | |
69 | ;;; as variadic arguments, answering the new seeds as values. | |
70 | (define-record-type srfi-37:option | |
71 | (option names required-arg? optional-arg? processor) | |
72 | option? | |
73 | (names option-names) | |
74 | (required-arg? option-required-arg?) | |
75 | (optional-arg? option-optional-arg?) | |
76 | (processor option-processor)) | |
77 | ||
78 | (define (error-duplicate-option option-name) | |
79 | (scm-error 'program-error "args-fold" | |
80 | "Duplicate option name `~A~A'" | |
81 | (list (if (char? option-name) #\- "--") | |
82 | option-name) | |
83 | #f)) | |
84 | ||
85 | (define (build-options-lookup options) | |
86 | "Answer an `equal?' Guile hash-table that maps OPTIONS' names back | |
87 | to the containing options, signalling an error if a name is | |
88 | encountered more than once." | |
89 | (let ((lookup (make-hash-table (* 2 (length options))))) | |
90 | (for-each | |
91 | (lambda (opt) | |
92 | (for-each (lambda (name) | |
93 | (let ((assoc (hash-create-handle! | |
94 | lookup name #f))) | |
95 | (if (cdr assoc) | |
96 | (error-duplicate-option (car assoc)) | |
97 | (set-cdr! assoc opt)))) | |
98 | (option-names opt))) | |
99 | options) | |
100 | lookup)) | |
101 | ||
102 | (define (args-fold args options unrecognized-option-proc | |
103 | operand-proc . seeds) | |
104 | "Answer the results of folding SEEDS as multiple values against the | |
105 | program-arguments in ARGS, as decided by the OPTIONS' | |
106 | `option-processor's, UNRECOGNIZED-OPTION-PROC, and OPERAND-PROC." | |
107 | (let ((lookup (build-options-lookup options))) | |
108 | ;; I don't like Guile's `error' here | |
109 | (define (error msg . args) | |
110 | (scm-error 'misc-error "args-fold" msg args #f)) | |
111 | ||
112 | (define (mutate-seeds! procedure . params) | |
113 | (set! seeds (call-with-values | |
114 | (lambda () | |
115 | (apply procedure (append params seeds))) | |
116 | list))) | |
117 | ||
118 | ;; Clean up the rest of ARGS, assuming they're all operands. | |
119 | (define (rest-operands) | |
120 | (for-each (lambda (arg) (mutate-seeds! operand-proc arg)) | |
121 | args) | |
122 | (set! args '())) | |
123 | ||
124 | ;; Call OPT's processor with OPT, NAME, an argument to be decided, | |
125 | ;; and the seeds. Depending on OPT's *-arg? specification, get | |
126 | ;; the parameter by calling REQ-ARG-PROC or OPT-ARG-PROC thunks; | |
127 | ;; if no argument is allowed, call NO-ARG-PROC thunk. | |
128 | (define (invoke-option-processor | |
129 | opt name req-arg-proc opt-arg-proc no-arg-proc) | |
130 | (mutate-seeds! | |
131 | (option-processor opt) opt name | |
132 | (cond ((option-required-arg? opt) (req-arg-proc)) | |
133 | ((option-optional-arg? opt) (opt-arg-proc)) | |
134 | (else (no-arg-proc) #f)))) | |
135 | ||
136 | ;; Compute and answer a short option argument, advancing ARGS as | |
137 | ;; necessary, for the short option whose character is at POSITION | |
138 | ;; in the current ARG. | |
139 | (define (short-option-argument position) | |
140 | (cond ((< (1+ position) (string-length (car args))) | |
141 | (let ((result (substring (car args) (1+ position)))) | |
142 | (set! args (cdr args)) | |
143 | result)) | |
144 | ((pair? (cdr args)) | |
145 | (let ((result (cadr args))) | |
146 | (set! args (cddr args)) | |
147 | result)) | |
148 | ((pair? args) | |
149 | (set! args (cdr args)) | |
150 | #f) | |
151 | (else #f))) | |
152 | ||
153 | ;; Interpret the short-option at index POSITION in (car ARGS), | |
154 | ;; followed by the remaining short options in (car ARGS). | |
155 | (define (short-option position) | |
156 | (if (>= position (string-length (car args))) | |
157 | (begin | |
158 | (set! args (cdr args)) | |
159 | (next-arg)) | |
160 | (let* ((opt-name (string-ref (car args) position)) | |
161 | (option-here (hash-ref lookup opt-name))) | |
162 | (cond ((not option-here) | |
163 | (mutate-seeds! unrecognized-option-proc | |
164 | (option (list opt-name) #f #f | |
165 | unrecognized-option-proc) | |
166 | opt-name #f) | |
167 | (short-option (1+ position))) | |
168 | (else | |
169 | (invoke-option-processor | |
170 | option-here opt-name | |
171 | (lambda () | |
172 | (or (short-option-argument position) | |
173 | (error "Missing required argument after `-~A'" opt-name))) | |
174 | (lambda () | |
175 | ;; edge case: -xo -zf or -xo -- where opt-name=#\o | |
176 | ;; GNU getopt_long resolves these like I do | |
177 | (short-option-argument position)) | |
178 | (lambda () #f)) | |
179 | (if (not (or (option-required-arg? option-here) | |
180 | (option-optional-arg? option-here))) | |
181 | (short-option (1+ position)))))))) | |
182 | ||
183 | ;; Process the long option in (car ARGS). We make the | |
184 | ;; interesting, possibly non-standard assumption that long option | |
185 | ;; names might contain #\=, so keep looking for more #\= in (car | |
186 | ;; ARGS) until we find a named option in lookup. | |
187 | (define (long-option) | |
188 | (let ((arg (car args))) | |
189 | (let place-=-after ((start-pos 2)) | |
190 | (let* ((index (string-index arg #\= start-pos)) | |
191 | (opt-name (substring arg 2 (or index (string-length arg)))) | |
192 | (option-here (hash-ref lookup opt-name))) | |
193 | (if (not option-here) | |
194 | ;; look for a later #\=, unless there can't be one | |
195 | (if index | |
196 | (place-=-after (1+ index)) | |
197 | (mutate-seeds! | |
198 | unrecognized-option-proc | |
199 | (option (list opt-name) #f #f unrecognized-option-proc) | |
200 | opt-name #f)) | |
201 | (invoke-option-processor | |
202 | option-here opt-name | |
203 | (lambda () | |
204 | (if index | |
205 | (substring arg (1+ index)) | |
206 | (error "Missing required argument after `--~A'" opt-name))) | |
207 | (lambda () (and index (substring arg (1+ index)))) | |
208 | (lambda () | |
209 | (if index | |
210 | (error "Extraneous argument after `--~A'" opt-name)))))))) | |
211 | (set! args (cdr args))) | |
212 | ||
213 | ;; Process the remaining in ARGS. Basically like calling | |
214 | ;; `args-fold', but without having to regenerate `lookup' and the | |
215 | ;; funcs above. | |
216 | (define (next-arg) | |
217 | (if (null? args) | |
218 | (apply values seeds) | |
219 | (let ((arg (car args))) | |
220 | (cond ((or (not (char=? #\- (string-ref arg 0))) | |
221 | (= 1 (string-length arg))) ;"-" | |
222 | (mutate-seeds! operand-proc arg) | |
223 | (set! args (cdr args))) | |
224 | ((char=? #\- (string-ref arg 1)) | |
225 | (if (= 2 (string-length arg)) ;"--" | |
226 | (begin (set! args (cdr args)) (rest-operands)) | |
227 | (long-option))) | |
228 | (else (short-option 1))) | |
229 | (next-arg)))) | |
230 | ||
231 | (next-arg))) | |
232 | ||
233 | ;;; srfi-37.scm ends here |