suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

* Arguments can now be passed directly as lists

Browse Source 
* Keywords are compared for the literal symbol instead of comparing ids
* Added tests for the above
* Some re-formatting

svn: r2356
This commit is contained in:
Eli Barzilay 2006-03-03 14:48:22 +00:00
parent c81cdb47b9
commit 776e15490e
2 changed files with 174 additions and 177 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

139
collects/mzlib/cmdline.ss
View File

@ -1,36 +1,23 @@
(module cmdline mzscheme (module cmdline mzscheme
(define-syntax command-line (define-syntax (command-line stx)
(lambda (stx) (define (id=? x y)
(syntax-case stx () (eq? (if (syntax? x) (syntax-e x) x) (if (syntax? y) (syntax-e y) y)))
[(_ program-name (define (serror msg . detail)
argv (apply raise-syntax-error #f msg stx detail))
clause ...) (define (extract-one what args . detail)
(let ([serror
(lambda (msg . detail)
(apply
raise-syntax-error
#f
msg
stx
detail))])
(let ([extract-one
(lambda (what args . detail)
(if (null? args) (if (null? args)
(apply serror (format "missing ~a" what) detail) (apply serror (format "missing ~a" what) detail)
(values (car args) (cdr args))))] (values (car args) (cdr args))))
[extract-list (define (extract-list stx/list pred)
(lambda (stx/list pred)
(let loop ([xs null] (let loop ([xs null]
[rest (if (syntax? stx/list) (syntax->list stx/list) stx/list)]) [rest (if (syntax? stx/list) (syntax->list stx/list) stx/list)])
(if (and (pair? rest) (pred (car rest))) (if (and (pair? rest) (pred (car rest)))
(loop (cons (car rest) xs) (cdr rest)) (loop (cons (car rest) xs) (cdr rest))
(values (reverse xs) rest))))] (values (reverse xs) rest))))
[formal-names (define (formal-names l)
(lambda (l) (map (lambda (a)
(map
(lambda (a)
(datum->syntax-object (datum->syntax-object
(quote-syntax here) (quote-syntax here)
(let ([s (symbol->string (syntax-e a))]) (let ([s (symbol->string (syntax-e a))])
@ -38,32 +25,31 @@
(substring s 0 (sub1 (string-length s))) (substring s 0 (sub1 (string-length s)))
s)) s))
#f)) #f))
l))]) l))
(syntax-case stx ()
[(_ program-name argv clause ...)
(let ([clauses (let ([clauses
(let loop ([csrcs (syntax->list (syntax (clause ...)))][clauses null]) (let loop ([csrcs (syntax->list #'(clause ...))][clauses null])
(with-syntax ([(clause ...) clauses]) (with-syntax ([(clause ...) clauses])
(if (null? csrcs) (if (null? csrcs)
(syntax ((list clause ...) (lambda (accum) (void)) null)) #'((list clause ...) (lambda (accum) (void)) null)
(let ([line (car csrcs)] (let ([line (car csrcs)]
[arest (cdr csrcs)]) [arest (cdr csrcs)])
(syntax-case line (help-labels => args) (syntax-case* line (help-labels => args) id=?
[(help-labels s ...) [(help-labels s ...)
(begin (begin
(unless (andmap (lambda (x) (string? (syntax-e x))) (unless (andmap (lambda (x) (string? (syntax-e x)))
(syntax->list (syntax (s ...)))) (syntax->list #'(s ...)))
(serror "help-labels clause must contain only strings" line)) (serror "help-labels clause must contain only strings" line))
(loop arest (loop arest #'(clause ... '(help-labels s ...))))]
(syntax (clause
...
'(help-labels s ...)))))]
[(tag . rest) [(tag . rest)
(ormap (lambda (x) (module-identifier=? (syntax tag) x)) (ormap (lambda (x) (id=? #'tag x))
(syntax->list (syntax (once-each once-any multi final)))) (syntax->list #'(once-each once-any multi final)))
(with-syntax (with-syntax
([sublines ([sublines
(let slloop ([sublines (syntax->list (syntax rest))]) (let slloop ([sublines (syntax->list #'rest)])
(if (null? sublines) (if (null? sublines)
(syntax ()) #'()
(with-syntax (with-syntax
([looped (slloop (cdr sublines))] ([looped (slloop (cdr sublines))]
[subline [subline
@ -74,22 +60,22 @@
(begin (begin
(unless (andmap (unless (andmap
(lambda (x) (string? (syntax-e x))) (lambda (x) (string? (syntax-e x)))
(syntax->list (syntax (flag ...)))) (syntax->list #'(flag ...)))
(serror (serror
"flag specification is not a string or sequence of strings" "flag specification is not a string or sequence of strings"
(syntax (flag ...)))) #'(flag ...)))
(syntax (flag ...)))] #'(flag ...))]
[(flag . rest) [(flag . rest)
(string? (syntax-e (syntax flag))) (string? (syntax-e #'flag))
(syntax (flag))] #'(flag)]
[else [else
(serror "clause does not start with flags")])]) (serror "clause does not start with flags")])])
(syntax-case (car sublines) (=>) (syntax-case (car sublines) (=>)
[(_ => a b) [(_ => a b)
(syntax (list 'flags a b))] #'(list 'flags a b)]
[(_ rest ...) [(_ rest ...)
(let*-values ([(formals rest) (let*-values ([(formals rest)
(extract-list (syntax (rest ...)) identifier?)] (extract-list #'(rest ...) identifier?)]
[(helps rest) [(helps rest)
(extract-list (extract-list
rest (lambda (x) (string? (syntax-e x))))] rest (lambda (x) (string? (syntax-e x))))]
@ -103,36 +89,28 @@
[helps helps] [helps helps]
[expr1 expr1] [expr1 expr1]
[rest rest]) [rest rest])
(syntax (list 'flags #'(list 'flags
(lambda (flag . formals) (lambda (flag . formals) expr1 . rest)
expr1 . rest) '(helps . formal-names))))]))])
'(helps . formal-names)))))]))]) #'(subline . looped))))])
(syntax (subline . looped)))))]) (loop arest #'(clause ... (list 'tag . sublines))))]
(loop arest
(syntax (clause
...
(list 'tag . sublines)))))]
[(=> finish-proc arg-help help-proc unknown-proc) [(=> finish-proc arg-help help-proc unknown-proc)
(begin (begin
(unless (null? arest) (unless (null? arest)
(serror "=> must be the last clause line")) (serror "=> must be the last clause line"))
(syntax ((list clause #'((list clause ...)
...) finish-proc arg-help help-proc unknown-proc))]
finish-proc arg-help help-proc unknown-proc)))]
[(=> finish-proc arg-help help-proc) [(=> finish-proc arg-help help-proc)
(begin (begin
(unless (null? arest) (unless (null? arest)
(serror "=> must be the last clause line")) (serror "=> must be the last clause line"))
(syntax ((list clause #'((list clause ...)
...) finish-proc arg-help help-proc))]
finish-proc arg-help help-proc)))]
[(=> finish-proc arg-help) [(=> finish-proc arg-help)
(begin (begin
(unless (null? arest) (unless (null? arest)
(serror "=> must be the last clause line")) (serror "=> must be the last clause line"))
(syntax ((list clause #'((list clause ...) finish-proc arg-help))]
...)
finish-proc arg-help)))]
[(=> . _) [(=> . _)
(serror "bad => line" line)] (serror "bad => line" line)]
[(args arg-formals body1 body ...) [(args arg-formals body1 body ...)
@ -140,33 +118,27 @@
(unless (null? arest) (unless (null? arest)
(serror "args must be the last clause" line)) (serror "args must be the last clause" line))
(let ([formals (let ([formals
(let loop ([f (syntax arg-formals)]) (let loop ([f #'arg-formals])
(syntax-case f () (syntax-case f ()
[() null] [() null]
[(arg . rest) [(arg . rest)
(identifier? (syntax arg)) (identifier? #'arg)
(cons (syntax arg) (loop (syntax rest)))] (cons #'arg (loop #'rest))]
[arg [arg
(identifier? (syntax arg)) (identifier? #'arg)
(list (syntax arg))] (list #'arg)]
[else [else
(serror "bad argument list" line)]))]) (serror "bad argument list" line)]))])
(with-syntax ([formal-names (formal-names formals)]) (with-syntax ([formal-names (formal-names formals)])
(syntax ((list clause #'((list clause ...)
...)
(lambda (accume . arg-formals) (lambda (accume . arg-formals)
body1 body ...) body1 body ...)
'formal-names)))))] 'formal-names))))]
[(args . _) [(args . _)
(serror "bad args line" line)] (serror "bad args line" line)]
[else (serror "not a once-each, once-any, multi, final, args, or => line" line)])))))]) [else (serror "not a once-each, once-any, multi, final, args, or => line" line)])))))])
(with-syntax ([clauses clauses]) (with-syntax ([clauses clauses])
(syntax #'(parse-command-line program-name argv . clauses)))]))
(parse-command-line
program-name argv
. clauses))))))])))
(define number-regexp (regexp "^[-+][0-9]*(|[.][0-9]*)$"))
(define print-args (define print-args
(lambda (port l f) (lambda (port l f)
@ -210,12 +182,13 @@
(parse-command-line program arguments table finish finish-help help (parse-command-line program arguments table finish finish-help help
(lambda (flag) (lambda (flag)
(raise-user-error (string->symbol program) "unknown flag: ~s" flag)))] (raise-user-error (string->symbol program) "unknown flag: ~s" flag)))]
[(program arguments table finish finish-help help unknown-flag) [(program arguments0 table finish finish-help help unknown-flag)
(define arguments (if (vector? arguments0) (vector->list arguments0) arguments0))
(unless (string? program) (unless (string? program)
(raise-type-error 'parse-command-line "program name string" program)) (raise-type-error 'parse-command-line "program name string" program))
(unless (and (vector? arguments) (unless (and (list? arguments)
(andmap string? (vector->list arguments))) (andmap string? arguments))
(raise-type-error 'parse-command-line "argument vector of strings" arguments)) (raise-type-error 'parse-command-line "argument vector/list of strings" arguments0))
(unless (and (list? table) (unless (and (list? table)
(let ([bad-table (let ([bad-table
(lambda (reason) (lambda (reason)
@ -253,7 +226,7 @@
(regexp-match #rx"^[+][+]." flag)) (regexp-match #rx"^[+][+]." flag))
(not (or (regexp-match #rx"^--help$" flag) (not (or (regexp-match #rx"^--help$" flag)
(regexp-match #rx"^-h$" flag) (regexp-match #rx"^-h$" flag)
(regexp-match number-regexp flag)))) (regexp-match #rx"^[-+][0-9]*(|[.][0-9]*)$" flag))))
(bad-table (format "no ill-formed or pre-defined flags: ~e" flag)))) (bad-table (format "no ill-formed or pre-defined flags: ~e" flag))))
(car line)) (car line))
@ -503,7 +476,7 @@
(set-car! set #t)))) (set-car! set #t))))
(call-handler (caddar table) flag args r-acc k)] (call-handler (caddar table) flag args r-acc k)]
[else (loop (cdr table))])))]) [else (loop (cdr table))])))])
(let loop ([args (vector->list arguments)][r-acc null]) (let loop ([args arguments][r-acc null])
(if (null? args) (if (null? args)
(done args r-acc) (done args r-acc)
(let ([arg (car args)] (let ([arg (car args)]
@ -511,7 +484,7 @@
(cond (cond
[finalled? [finalled?
(done args r-acc)] (done args r-acc)]
[(regexp-match number-regexp arg) [(regexp-match #rx"^[-+][0-9]*(|[.][0-9]*)$" arg)
(done args r-acc)] (done args r-acc)]
[(regexp-match "^--$" arg) [(regexp-match "^--$" arg)
(done (cdr args) r-acc)] (done (cdr args) r-acc)]

26
collects/tests/mzscheme/cmdline.ss
View File

@ -21,6 +21,20 @@
r-append r-append
'("arg")) '("arg"))
;; test that args can be a list instead of a vector
(test '("-bye" #())
parse-command-line
"test"
'("--hi" "-bye")
(list
(list
'multi
(list (list "--hi")
(lambda (flag v) v)
(list "Hello" "x"))))
r-append
'("arg"))
(test '("1" "2" #("3")) (test '("1" "2" #("3"))
parse-command-line parse-command-line
"test" "test"
@ -155,11 +169,21 @@
(err/rt-test (parse-command-line "test" #() null (lambda (x y) null) null) exn:fail?) (err/rt-test (parse-command-line "test" #() null (lambda (x y) null) null) exn:fail?)
(test (void) 'cmdline (command-line "something" #("-ab") (test (void) 'cmdline
(command-line "something" #("-ab")
(once-each (once-each
[("-a") "ok" 5] [("-a") "ok" 5]
[("-b" "--more") "Help" 7]))) [("-b" "--more") "Help" 7])))
;; test that keywords are compared for the literal symbol
(test "foo" 'cmdline
(let ([once-each 3] [args "args"])
(command-line "something" #("-ab" "foo")
(once-each
[("-a") "ok" 5]
[("-b" "--more") "Help" 7])
(args (x) x))))
(syntax-test #'(command-line)) (syntax-test #'(command-line))
(syntax-test #'(command-line "hello")) (syntax-test #'(command-line "hello"))
(err/rt-test (command-line 'hello #("ok"))) (err/rt-test (command-line 'hello #("ok")))