1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
|
;;; WORK IN PROGRESS, NOT FOR CONSUMPTION
;;; TODO: long options
;;; multiple options in one go, e.g., -XYZ
;;; concat value with option, e.g., -Xxvalue
;;; usage error message [ok?]
;;; -h --help should not be user-defined
;;; check duplicate options
(library (command-line)
(export command-line-interface)
(import (rnrs))
(define (dispatch-opts arguments data* proc*)
(define (print p . args)
(for-each (lambda (x) (display x p)) args))
(define (print-usage detailed?)
(define-record-type f (fields id char type def))
(define (mkf x id)
(make-f id (car x) (cadr x) (cddr x)))
(define (get type ls)
(filter (lambda (x) (eq? (f-type x) type)) ls))
(define (fmt-req p)
(lambda (x)
(print p " -" (f-char x) " <" (f-id x) ">")))
(define (fmt-req-no-value p)
(lambda (x)
(display " -" p)
(display (f-char x) p)))
(define (fmt-z p c)
(lambda (x)
(print p " [-" (f-char x) " <" (f-id x) ">]" c)))
(define (fmt-<> p)
(lambda (x)
(display " <" p)
(display x p)
(display ">" p)))
(define (synopsis f* args args-rest)
(let ([opt* (get 'optional f*)]
[flag* (get 'flag f*)]
[req0* (get 'required0 f*)]
[req1* (get 'required1 f*)]
[z0* (get 'zero-plus f*)]
[z1* (get 'one-plus f*)])
(let-values ([(p e) (open-string-output-port)])
(display (car arguments) p)
(for-each (fmt-req-no-value p) req0*)
(unless (null? flag*)
(display " [-" p)
(apply print p (map f-char flag*))
(display "]" p))
(for-each (fmt-z p "") opt*)
(for-each (fmt-z p "*") z0*)
(for-each (fmt-z p "+") z1*)
(for-each (fmt-req p) req1*)
(for-each (fmt-<> p) args)
(when args-rest
((fmt-<> p) args-rest)
(display " ..." p))
(e))))
(define (print-usage-line help fields field-ids args args-rest dash-rest)
(let ([f* (map mkf fields field-ids)])
(display " ")
(display (synopsis f* args args-rest))
(newline)
(unless (string=? help "")
(display " ")
(display help)
(newline))
(when detailed?
(let ([def* (filter f-def (get 'optional f*))])
(unless (null? def*)
(for-each
(lambda (x)
(print (current-output-port)
" -" (f-char x)
" defaults to " (f-def x)
"\n"))
def*)))
(newline))))
(display "\nUsage:\n")
(for-each (lambda (x) (apply print-usage-line x)) data*)
(print-usage-line "Display this help message"
'([#\h required0 . #f])
'(dummy)
'()
#f
#f)
#f)
(define (arguments-match)
(define-condition-type &help &condition
make-help-condition help-condition?
(extended? help-extended?))
(define-condition-type &unmatched &condition
make-unmatched-condition unmatched-condition?)
(define (help x)
(raise (make-help-condition x)))
(define (unmatched)
(raise (make-unmatched-condition)))
(define (option? x)
(or (equal? x "--help") ;;; hack
(and (string? x)
(>= (string-length x) 2)
(char=? (string-ref x 0) #\-)
(not (char=? (string-ref x 1) #\-)))))
;;;
(define (fill-char-opt c ls fields)
;;; field = [c required0 . _] ; requires 0 args
;;; | [c required1 . _] ; requires 1 arg
;;; | [c flag . default] ; toggles default to #t
;;; | [c zero-plus . reversed-list]
;;; | [c one-plus . reversed-list]
;;; | [c optional . default] ; overridden by value
;;; | [c ok . value] ; already used, not on input
(let f ([fields fields])
(when (null? fields) (unmatched))
(let ([field (car fields)])
(if (char=? c (car field))
(let ([t (cadr field)])
(case t
[(required1 optional)
(when (null? ls) (unmatched))
(let ([val (car ls)] [ls (cdr ls)])
(values (cons (cons* c 'ok val) (cdr fields)) ls))]
[(flag)
(values (cons (cons* c 'ok #t) (cdr fields)) ls)]
[(zero-plus one-plus)
(when (null? ls) (unmatched))
(let ([val (car ls)])
(values
(cons (cons* c 'zero-plus (cons val (cddr field)))
(cdr fields))
(cdr ls)))]
[else (unmatched)]))
(let-values ([(fields ls) (f (cdr fields))])
(values (cons field fields) ls))))))
;;;
(define (fill-option a ls fields)
(when (string=? a "--help") (help #t))
(if (= (string-length a) 2)
(let ([char (string-ref a 1)])
(when (char=? char #\h) (help #f))
(fill-char-opt char ls fields))
(error 'fill-option "not yet")))
;;;
(define (match-fields fields ls)
(if (null? ls)
(values fields ls)
(let ([a (car ls)])
(if (option? a)
(let-values ([(fields ls) (fill-option a (cdr ls) fields)])
(match-fields fields ls))
(values fields ls)))))
;;;
(define (match-args args ls)
(cond
[(null? args) (values '() ls)]
[(null? ls) (unmatched)]
[else
(let ([a (car ls)])
(when (option? a) (unmatched))
(let-values ([(a* ls) (match-args (cdr args) (cdr ls))])
(values (cons a a*) ls)))]))
;;;
(define (match-args-rest a/f ls)
(if a/f
(let-values ([(x ls)
(let f ([ls ls])
(if (null? ls)
(values '() ls)
(let ([a (car ls)])
(if (string=? a "--")
(values '() ls)
(if (option? a)
(unmatched)
(let-values ([(a* ls) (f (cdr ls))])
(values (cons a a*) ls)))))))])
(values (list x) ls))
(if (or (null? ls) (string=? (car ls) "--"))
(values '() ls)
(unmatched))))
;;;
(define (match-dash-rest a/f ls)
(if a/f
(if (null? ls)
'(())
(if (string=? (car ls) "--")
(list (cdr ls))
(unmatched)))
(if (null? ls) '() (unmatched))))
;;;
(define (fix-field x)
(let ([type (cadr x)] [value (cddr x)])
(case type
[(ok flag optional) value]
[(zero-plus) (reverse value)]
[else (unmatched)])))
;;;
(define (match _help fields _field-ids args args-rest dash-rest)
(cons (car arguments)
(let*-values ([(fields ls) (match-fields fields (cdr arguments))]
[(fields) (map fix-field fields)]
[(args ls) (match-args args ls)]
[(args-rest ls) (match-args-rest args-rest ls)]
[(dash-rest) (match-dash-rest dash-rest ls)])
(append fields args args-rest dash-rest))))
;;;
(guard (con
[(help-condition? con)
(print-usage (help-extended? con))])
(let f ([data* data*] [proc* proc*])
(if (null? data*)
(help #f)
(guard (con
[(unmatched-condition? con)
(f (cdr data*) (cdr proc*))])
(apply (car proc*) (apply match (car data*))))))))
(arguments-match))
(define-syntax command-line-interface
(lambda (stx)
(define (parse-format stx)
(define (err str x)
(syntax-violation #f str stx x))
(define (prep-str stx)
(let* ([str (syntax->datum stx)]
[n (string-length str)]
[err (lambda (why) (err why stx))])
(when (< n 2) (err "invalid option string"))
(unless (char=? (string-ref str 0) #\-)
(err "option string must start with a dash: -"))
(cons (string-ref str 1)
(cond
[(= n 2) #'(required1)]
[else
(case (string-ref str 2)
[(#\?) #'(flag . #f)]
[(#\*) #'(zero-plus . ())]
[(#\+) #'(one-plus . ())]
[(#\=)
(cons #'optional (substring str 3 n))]
[else (err "invalid option")])]))))
(define (dots? x)
(and (identifier? x)
(free-identifier=? x #'(... ...))))
(define (id? x)
(and (identifier? x) (not (dots? x))))
;;;
(define (command-line-interface ls)
(define (str? x)
(let ([d (syntax->datum x)])
(and (string? d) (not (string=? d "--")))))
(define (parse-head x)
(syntax-case x ()
[(prog . rest)
(if (id? #'prog)
(values #'prog #'rest)
(err "pattern head is not an identifier" #'prog))]
[_ (err "invalid pattern" x)]))
(define (parse-opts x)
(syntax-case x ()
[(str id . rest)
(and (id? #'id) (str? #'str))
(let-values ([(opt-strs opt-ids rest) (parse-opts #'rest)])
(values (cons (prep-str #'str) opt-strs)
(cons #'id opt-ids) rest))]
[_ (values '() '() x)]))
(define (parse-args x)
(syntax-case x ()
[(id dots . rest)
(and (id? #'id) (dots? #'dots))
(values '() #'id #'rest)]
[(id . rest) (id? #'id)
(let-values ([(args args-rest rest) (parse-args #'rest)])
(values (cons #'id args) args-rest rest))]
[_ (values '() #f x)]))
(define (parse-tail x)
(syntax-case x ()
[("--" id) (id? #'id) #'id]
[() #f]
[_ (err "invalid pattern segment" x)]))
(let-values ([(prog ls) (parse-head ls)])
(let-values ([(opts opt-ids ls) (parse-opts ls)])
(let-values ([(args args-rest ls) (parse-args ls)])
(values prog opts opt-ids args args-rest (parse-tail ls))))))
(define (get-fmls x ls1 ls2 m1 m2)
(define (cons? x ls) (if x (cons x ls) ls))
(define (bound-id-member? x ls)
(and (pair? ls)
(or (bound-identifier=? x (car ls))
(bound-id-member? x (cdr ls)))))
(let ([ls (cons x (append ls1 ls2 (cons? m1 (cons? m2 '()))))])
(let f ([x (car ls)] [ls (cdr ls)])
(unless (null? ls)
(if (bound-id-member? x ls)
(err "duplicate identifier" x)
(f (car ls) (cdr ls)))))
ls))
(let-values ([(prog opt-strs opt-ids args args-rest dash-rest)
(command-line-interface stx)])
(list (get-fmls prog opt-ids args args-rest dash-rest)
opt-strs opt-ids args args-rest dash-rest)))
(define (parse-clause stx)
(syntax-case stx ()
[(format help-str body body* ...)
(string? (syntax->datum #'help-str))
(with-syntax ([((fmls ...) . args)
(parse-format #'format)])
(list #'(lambda (fmls ...) body body* ...)
#'(help-str . args)))]
[(format body body* ...)
(parse-clause #'(format "" body body* ...))]))
(syntax-case stx ()
[(_ expr clause* ...)
(with-syntax ([((proc* data*) ...)
(map parse-clause #'(clause* ...))])
#'(dispatch-opts expr '(data* ...) (list proc* ...)))])))
)
|
