* Arguments can now be passed directly as lists
* 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
parent
c81cdb47b9
commit
776e15490e
|
|
@ -1,173 +1,145 @@
|
||||||
|
|
||||||
(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
|
(if (null? args)
|
||||||
(lambda (msg . detail)
|
(apply serror (format "missing ~a" what) detail)
|
||||||
(apply
|
(values (car args) (cdr args))))
|
||||||
raise-syntax-error
|
(define (extract-list stx/list pred)
|
||||||
#f
|
(let loop ([xs null]
|
||||||
msg
|
[rest (if (syntax? stx/list) (syntax->list stx/list) stx/list)])
|
||||||
stx
|
(if (and (pair? rest) (pred (car rest)))
|
||||||
detail))])
|
(loop (cons (car rest) xs) (cdr rest))
|
||||||
(let ([extract-one
|
(values (reverse xs) rest))))
|
||||||
(lambda (what args . detail)
|
(define (formal-names l)
|
||||||
(if (null? args)
|
(map (lambda (a)
|
||||||
(apply serror (format "missing ~a" what) detail)
|
(datum->syntax-object
|
||||||
(values (car args) (cdr args))))]
|
(quote-syntax here)
|
||||||
[extract-list
|
(let ([s (symbol->string (syntax-e a))])
|
||||||
(lambda (stx/list pred)
|
(if (char=? #\* (string-ref s (sub1 (string-length s))))
|
||||||
(let loop ([xs null]
|
(substring s 0 (sub1 (string-length s)))
|
||||||
[rest (if (syntax? stx/list) (syntax->list stx/list) stx/list)])
|
s))
|
||||||
(if (and (pair? rest) (pred (car rest)))
|
#f))
|
||||||
(loop (cons (car rest) xs) (cdr rest))
|
l))
|
||||||
(values (reverse xs) rest))))]
|
(syntax-case stx ()
|
||||||
[formal-names
|
[(_ program-name argv clause ...)
|
||||||
(lambda (l)
|
(let ([clauses
|
||||||
(map
|
(let loop ([csrcs (syntax->list #'(clause ...))][clauses null])
|
||||||
(lambda (a)
|
(with-syntax ([(clause ...) clauses])
|
||||||
(datum->syntax-object
|
(if (null? csrcs)
|
||||||
(quote-syntax here)
|
#'((list clause ...) (lambda (accum) (void)) null)
|
||||||
(let ([s (symbol->string (syntax-e a))])
|
(let ([line (car csrcs)]
|
||||||
(if (char=? #\* (string-ref s (sub1 (string-length s))))
|
[arest (cdr csrcs)])
|
||||||
(substring s 0 (sub1 (string-length s)))
|
(syntax-case* line (help-labels => args) id=?
|
||||||
s))
|
[(help-labels s ...)
|
||||||
#f))
|
(begin
|
||||||
l))])
|
(unless (andmap (lambda (x) (string? (syntax-e x)))
|
||||||
(let ([clauses
|
(syntax->list #'(s ...)))
|
||||||
(let loop ([csrcs (syntax->list (syntax (clause ...)))][clauses null])
|
(serror "help-labels clause must contain only strings" line))
|
||||||
(with-syntax ([(clause ...) clauses])
|
(loop arest #'(clause ... '(help-labels s ...))))]
|
||||||
(if (null? csrcs)
|
[(tag . rest)
|
||||||
(syntax ((list clause ...) (lambda (accum) (void)) null))
|
(ormap (lambda (x) (id=? #'tag x))
|
||||||
(let ([line (car csrcs)]
|
(syntax->list #'(once-each once-any multi final)))
|
||||||
[arest (cdr csrcs)])
|
(with-syntax
|
||||||
(syntax-case line (help-labels => args)
|
([sublines
|
||||||
[(help-labels s ...)
|
(let slloop ([sublines (syntax->list #'rest)])
|
||||||
(begin
|
(if (null? sublines)
|
||||||
(unless (andmap (lambda (x) (string? (syntax-e x)))
|
#'()
|
||||||
(syntax->list (syntax (s ...))))
|
(with-syntax
|
||||||
(serror "help-labels clause must contain only strings" line))
|
([looped (slloop (cdr sublines))]
|
||||||
(loop arest
|
[subline
|
||||||
(syntax (clause
|
(with-syntax
|
||||||
...
|
([flags
|
||||||
'(help-labels s ...)))))]
|
(syntax-case (car sublines) ()
|
||||||
[(tag . rest)
|
[((flag ...) . rest)
|
||||||
(ormap (lambda (x) (module-identifier=? (syntax tag) x))
|
(begin
|
||||||
(syntax->list (syntax (once-each once-any multi final))))
|
(unless (andmap
|
||||||
(with-syntax
|
(lambda (x) (string? (syntax-e x)))
|
||||||
([sublines
|
(syntax->list #'(flag ...)))
|
||||||
(let slloop ([sublines (syntax->list (syntax rest))])
|
(serror
|
||||||
(if (null? sublines)
|
"flag specification is not a string or sequence of strings"
|
||||||
(syntax ())
|
#'(flag ...)))
|
||||||
(with-syntax
|
#'(flag ...))]
|
||||||
([looped (slloop (cdr sublines))]
|
[(flag . rest)
|
||||||
[subline
|
(string? (syntax-e #'flag))
|
||||||
(with-syntax
|
#'(flag)]
|
||||||
([flags
|
[else
|
||||||
(syntax-case (car sublines) ()
|
(serror "clause does not start with flags")])])
|
||||||
[((flag ...) . rest)
|
(syntax-case (car sublines) (=>)
|
||||||
(begin
|
[(_ => a b)
|
||||||
(unless (andmap
|
#'(list 'flags a b)]
|
||||||
(lambda (x) (string? (syntax-e x)))
|
[(_ rest ...)
|
||||||
(syntax->list (syntax (flag ...))))
|
(let*-values ([(formals rest)
|
||||||
(serror
|
(extract-list #'(rest ...) identifier?)]
|
||||||
"flag specification is not a string or sequence of strings"
|
[(helps rest)
|
||||||
(syntax (flag ...))))
|
(extract-list
|
||||||
(syntax (flag ...)))]
|
rest (lambda (x) (string? (syntax-e x))))]
|
||||||
[(flag . rest)
|
[(expr1 rest)
|
||||||
(string? (syntax-e (syntax flag)))
|
(extract-one
|
||||||
(syntax (flag))]
|
"handler body expressions" rest line)])
|
||||||
[else
|
(when (null? helps)
|
||||||
(serror "clause does not start with flags")])])
|
(serror "missing help string/s"))
|
||||||
(syntax-case (car sublines) (=>)
|
(with-syntax ([formals formals]
|
||||||
[(_ => a b)
|
[formal-names (formal-names formals)]
|
||||||
(syntax (list 'flags a b))]
|
[helps helps]
|
||||||
[(_ rest ...)
|
[expr1 expr1]
|
||||||
(let*-values ([(formals rest)
|
[rest rest])
|
||||||
(extract-list (syntax (rest ...)) identifier?)]
|
#'(list 'flags
|
||||||
[(helps rest)
|
(lambda (flag . formals) expr1 . rest)
|
||||||
(extract-list
|
'(helps . formal-names))))]))])
|
||||||
rest (lambda (x) (string? (syntax-e x))))]
|
#'(subline . looped))))])
|
||||||
[(expr1 rest)
|
(loop arest #'(clause ... (list 'tag . sublines))))]
|
||||||
(extract-one
|
[(=> finish-proc arg-help help-proc unknown-proc)
|
||||||
"handler body expressions" rest line)])
|
(begin
|
||||||
(when (null? helps)
|
(unless (null? arest)
|
||||||
(serror "missing help string/s"))
|
(serror "=> must be the last clause line"))
|
||||||
(with-syntax ([formals formals]
|
#'((list clause ...)
|
||||||
[formal-names (formal-names formals)]
|
finish-proc arg-help help-proc unknown-proc))]
|
||||||
[helps helps]
|
[(=> finish-proc arg-help help-proc)
|
||||||
[expr1 expr1]
|
(begin
|
||||||
[rest rest])
|
(unless (null? arest)
|
||||||
(syntax (list 'flags
|
(serror "=> must be the last clause line"))
|
||||||
(lambda (flag . formals)
|
#'((list clause ...)
|
||||||
expr1 . rest)
|
finish-proc arg-help help-proc))]
|
||||||
'(helps . formal-names)))))]))])
|
[(=> finish-proc arg-help)
|
||||||
(syntax (subline . looped)))))])
|
(begin
|
||||||
(loop arest
|
(unless (null? arest)
|
||||||
(syntax (clause
|
(serror "=> must be the last clause line"))
|
||||||
...
|
#'((list clause ...) finish-proc arg-help))]
|
||||||
(list 'tag . sublines)))))]
|
[(=> . _)
|
||||||
[(=> finish-proc arg-help help-proc unknown-proc)
|
(serror "bad => line" line)]
|
||||||
(begin
|
[(args arg-formals body1 body ...)
|
||||||
(unless (null? arest)
|
(begin
|
||||||
(serror "=> must be the last clause line"))
|
(unless (null? arest)
|
||||||
(syntax ((list clause
|
(serror "args must be the last clause" line))
|
||||||
...)
|
(let ([formals
|
||||||
finish-proc arg-help help-proc unknown-proc)))]
|
(let loop ([f #'arg-formals])
|
||||||
[(=> finish-proc arg-help help-proc)
|
(syntax-case f ()
|
||||||
(begin
|
[() null]
|
||||||
(unless (null? arest)
|
[(arg . rest)
|
||||||
(serror "=> must be the last clause line"))
|
(identifier? #'arg)
|
||||||
(syntax ((list clause
|
(cons #'arg (loop #'rest))]
|
||||||
...)
|
[arg
|
||||||
finish-proc arg-help help-proc)))]
|
(identifier? #'arg)
|
||||||
[(=> finish-proc arg-help)
|
(list #'arg)]
|
||||||
(begin
|
[else
|
||||||
(unless (null? arest)
|
(serror "bad argument list" line)]))])
|
||||||
(serror "=> must be the last clause line"))
|
(with-syntax ([formal-names (formal-names formals)])
|
||||||
(syntax ((list clause
|
#'((list clause ...)
|
||||||
...)
|
(lambda (accume . arg-formals)
|
||||||
finish-proc arg-help)))]
|
body1 body ...)
|
||||||
[(=> . _)
|
'formal-names))))]
|
||||||
(serror "bad => line" line)]
|
[(args . _)
|
||||||
[(args arg-formals body1 body ...)
|
(serror "bad args line" line)]
|
||||||
(begin
|
[else (serror "not a once-each, once-any, multi, final, args, or => line" line)])))))])
|
||||||
(unless (null? arest)
|
(with-syntax ([clauses clauses])
|
||||||
(serror "args must be the last clause" line))
|
#'(parse-command-line program-name argv . clauses)))]))
|
||||||
(let ([formals
|
|
||||||
(let loop ([f (syntax arg-formals)])
|
|
||||||
(syntax-case f ()
|
|
||||||
[() null]
|
|
||||||
[(arg . rest)
|
|
||||||
(identifier? (syntax arg))
|
|
||||||
(cons (syntax arg) (loop (syntax rest)))]
|
|
||||||
[arg
|
|
||||||
(identifier? (syntax arg))
|
|
||||||
(list (syntax arg))]
|
|
||||||
[else
|
|
||||||
(serror "bad argument list" line)]))])
|
|
||||||
(with-syntax ([formal-names (formal-names formals)])
|
|
||||||
(syntax ((list clause
|
|
||||||
...)
|
|
||||||
(lambda (accume . arg-formals)
|
|
||||||
body1 body ...)
|
|
||||||
'formal-names)))))]
|
|
||||||
[(args . _)
|
|
||||||
(serror "bad args line" line)]
|
|
||||||
[else (serror "not a once-each, once-any, multi, final, args, or => line" line)])))))])
|
|
||||||
(with-syntax ([clauses clauses])
|
|
||||||
(syntax
|
|
||||||
(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)
|
||||||
(let loop ([l l][a (letrec ([a (procedure-arity f)]
|
(let loop ([l l][a (letrec ([a (procedure-arity 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)]
|
||||||
|
|
|
||||||
|
|
@ -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,10 +169,20 @@
|
||||||
|
|
||||||
(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
|
||||||
(once-each
|
(command-line "something" #("-ab")
|
||||||
[("-a") "ok" 5]
|
(once-each
|
||||||
[("-b" "--more") "Help" 7])))
|
[("-a") "ok" 5]
|
||||||
|
[("-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"))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user