new scheme/cmdline, refine -r/-u to imply -N
svn: r7989
This commit is contained in:
Matthew Flatt
parent
fa0c028d26
commit
138a38ea04
|
|
@ -1,18 +1,15 @@
|
||||||
#lang scheme/base
|
#lang scheme/base
|
||||||
|
|
||||||
(require "search.ss"
|
(require "search.ss"
|
||||||
net/sendurl ; browser/external
|
net/sendurl
|
||||||
setup/dirs
|
setup/dirs
|
||||||
mzlib/cmdline)
|
scheme/cmdline)
|
||||||
|
|
||||||
(define search-terms '())
|
(command-line
|
||||||
(command-line "Help Desk"
|
#:args search-term
|
||||||
(current-command-line-arguments)
|
(cond
|
||||||
(args search-term (set! search-terms search-term)))
|
[(null? search-term)
|
||||||
|
|
||||||
(cond
|
|
||||||
[(null? search-terms)
|
|
||||||
(let ([dest-path (build-path (find-doc-dir) "start" "index.html")])
|
(let ([dest-path (build-path (find-doc-dir) "start" "index.html")])
|
||||||
(send-url (format "file://~a" (path->string dest-path))))]
|
(send-url (format "file://~a" (path->string dest-path))))]
|
||||||
[else
|
[else
|
||||||
(generate-search-results search-terms)])
|
(generate-search-results search-term)]))
|
||||||
|
|
|
||||||
|
|
@ -7,7 +7,7 @@
|
||||||
scribble/basic
|
scribble/basic
|
||||||
scribble/manual
|
scribble/manual
|
||||||
(prefix-in scheme: scribble/scheme)
|
(prefix-in scheme: scribble/scheme)
|
||||||
net/sendurl ; browser/external
|
net/sendurl
|
||||||
mzlib/contract)
|
mzlib/contract)
|
||||||
|
|
||||||
(provide/contract
|
(provide/contract
|
||||||
|
|
|
||||||
|
|
@ -1,5 +0,0 @@
|
||||||
|
|
||||||
;; Temporary hack for building "scribblings" doc examples.
|
|
||||||
|
|
||||||
(module lang (lib "lang.ss" "big")
|
|
||||||
(provide (all-from (lib "lang.ss" "big"))))
|
|
||||||
|
|
@ -1,37 +1,41 @@
|
||||||
|
#lang mzscheme
|
||||||
|
|
||||||
(module cmdline mzscheme
|
(require (only scheme/cmdline parse-command-line))
|
||||||
|
|
||||||
(define-syntax (command-line stx)
|
(provide command-line
|
||||||
(define (id=? x y)
|
parse-command-line)
|
||||||
(eq? (if (syntax? x) (syntax-e x) x) (if (syntax? y) (syntax-e y) y)))
|
|
||||||
(define (serror msg . detail)
|
(define-syntax (command-line stx)
|
||||||
(apply raise-syntax-error #f msg stx detail))
|
(define (id=? x y)
|
||||||
(define (extract-one what args . detail)
|
(eq? (syntax-e x) (syntax-e y)))
|
||||||
(if (null? args)
|
(define (serror msg . detail)
|
||||||
|
(apply raise-syntax-error #f msg stx detail))
|
||||||
|
(define (extract-one what args . detail)
|
||||||
|
(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))))
|
||||||
(define (extract-list stx/list pred)
|
(define (extract-list 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))))
|
||||||
(define (formal-names l)
|
(define (formal-names 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))])
|
||||||
(if (char=? #\* (string-ref s (sub1 (string-length s))))
|
(if (char=? #\* (string-ref s (sub1 (string-length s))))
|
||||||
(substring s 0 (sub1 (string-length s)))
|
(substring s 0 (sub1 (string-length s)))
|
||||||
s))
|
s))
|
||||||
#f))
|
#f))
|
||||||
l))
|
l))
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_ program-name argv clause ...)
|
[(_ program-name argv clause ...)
|
||||||
(let ([clauses
|
(let ([clauses
|
||||||
(let loop ([csrcs (syntax->list #'(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)
|
||||||
#'((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)])
|
||||||
|
|
@ -49,50 +53,50 @@
|
||||||
([sublines
|
([sublines
|
||||||
(let slloop ([sublines (syntax->list #'rest)])
|
(let slloop ([sublines (syntax->list #'rest)])
|
||||||
(if (null? sublines)
|
(if (null? sublines)
|
||||||
#'()
|
#'()
|
||||||
(with-syntax
|
(with-syntax
|
||||||
([looped (slloop (cdr sublines))]
|
([looped (slloop (cdr sublines))]
|
||||||
[subline
|
[subline
|
||||||
(with-syntax
|
(with-syntax
|
||||||
([flags
|
([flags
|
||||||
(syntax-case (car sublines) ()
|
(syntax-case (car sublines) ()
|
||||||
[((flag ...) . rest)
|
[((flag ...) . rest)
|
||||||
(begin
|
(begin
|
||||||
(unless (andmap
|
(unless (andmap
|
||||||
(lambda (x) (string? (syntax-e x)))
|
(lambda (x) (string? (syntax-e x)))
|
||||||
(syntax->list #'(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"
|
||||||
#'(flag ...)))
|
#'(flag ...)))
|
||||||
#'(flag ...))]
|
#'(flag ...))]
|
||||||
[(flag . rest)
|
[(flag . rest)
|
||||||
(string? (syntax-e #'flag))
|
(string? (syntax-e #'flag))
|
||||||
#'(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) (=>) id=?
|
||||||
[(_ => a b)
|
[(_ => a b)
|
||||||
#'(list 'flags a b)]
|
#'(list 'flags a b)]
|
||||||
[(_ rest ...)
|
[(_ rest ...)
|
||||||
(let*-values ([(formals rest)
|
(let*-values ([(formals rest)
|
||||||
(extract-list #'(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))))]
|
||||||
[(expr1 rest)
|
[(expr1 rest)
|
||||||
(extract-one
|
(extract-one
|
||||||
"handler body expressions" rest line)])
|
"handler body expressions" rest line)])
|
||||||
(when (null? helps)
|
(when (null? helps)
|
||||||
(serror "missing help string/s"))
|
(serror "missing help string/s"))
|
||||||
(with-syntax ([formals formals]
|
(with-syntax ([formals formals]
|
||||||
[formal-names (formal-names formals)]
|
[formal-names (formal-names formals)]
|
||||||
[helps helps]
|
[helps helps]
|
||||||
[expr1 expr1]
|
[expr1 expr1]
|
||||||
[rest rest])
|
[rest rest])
|
||||||
#'(list 'flags
|
#'(list 'flags
|
||||||
(lambda (flag . formals) expr1 . rest)
|
(lambda (flag . formals) expr1 . rest)
|
||||||
'(helps . formal-names))))]))])
|
'(helps . formal-names))))]))])
|
||||||
#'(subline . looped))))])
|
#'(subline . looped))))])
|
||||||
(loop arest #'(clause ... (list 'tag . sublines))))]
|
(loop arest #'(clause ... (list 'tag . sublines))))]
|
||||||
[(=> finish-proc arg-help help-proc unknown-proc)
|
[(=> finish-proc arg-help help-proc unknown-proc)
|
||||||
(begin
|
(begin
|
||||||
|
|
@ -137,374 +141,5 @@
|
||||||
[(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])
|
||||||
#'(parse-command-line program-name argv . clauses)))]))
|
#'(parse-command-line program-name argv . clauses)))]))
|
||||||
|
|
||||||
(define print-args
|
|
||||||
(lambda (port l f)
|
|
||||||
(let loop ([l l][a (letrec ([a (procedure-arity f)]
|
|
||||||
[a-c (lambda (a)
|
|
||||||
(cond
|
|
||||||
[(number? a) (cons (sub1 a) (sub1 a))]
|
|
||||||
[(arity-at-least? a)
|
|
||||||
(let ([v (sub1 (arity-at-least-value a))])
|
|
||||||
(cons v v))]
|
|
||||||
[else (let ([r (map a-c a)])
|
|
||||||
(cons (apply min (map car r))
|
|
||||||
(apply max (map cdr r))))]))])
|
|
||||||
(a-c a))])
|
|
||||||
(unless (null? l)
|
|
||||||
(fprintf port " ~a<~a>~a"
|
|
||||||
(if (positive? (car a)) "" "[")
|
|
||||||
(car l)
|
|
||||||
(if (positive? (car a)) "" "]"))
|
|
||||||
(unless (positive? (cdr a))
|
|
||||||
(fprintf port " ..."))
|
|
||||||
(loop (cdr l) (cons (sub1 (car a)) (sub1 (cdr a))))))))
|
|
||||||
|
|
||||||
(define (procedure-arity-includes-at-least? p n)
|
|
||||||
(letrec ([a-c
|
|
||||||
(lambda (a)
|
|
||||||
(cond
|
|
||||||
[(number? a) (>= a n)]
|
|
||||||
[(arity-at-least? a) #t]
|
|
||||||
[else (ormap a-c a)]))])
|
|
||||||
(a-c (procedure-arity p))))
|
|
||||||
|
|
||||||
(define parse-command-line
|
|
||||||
(case-lambda
|
|
||||||
[(program arguments table finish finish-help)
|
|
||||||
(parse-command-line program arguments table finish finish-help
|
|
||||||
(lambda (s)
|
|
||||||
(display s)
|
|
||||||
(exit 0)))]
|
|
||||||
[(program arguments table finish finish-help help)
|
|
||||||
(parse-command-line program arguments table finish finish-help help
|
|
||||||
(lambda (flag)
|
|
||||||
(raise-user-error (string->symbol program) "unknown switch: ~s" flag)))]
|
|
||||||
[(program arguments0 table finish finish-help help unknown-flag)
|
|
||||||
(define arguments (if (vector? arguments0) (vector->list arguments0) arguments0))
|
|
||||||
(unless (string? program)
|
|
||||||
(raise-type-error 'parse-command-line "program name string" program))
|
|
||||||
(unless (and (list? arguments)
|
|
||||||
(andmap string? arguments))
|
|
||||||
(raise-type-error 'parse-command-line "argument vector/list of strings" arguments0))
|
|
||||||
(unless (and (list? table)
|
|
||||||
(let ([bad-table
|
|
||||||
(lambda (reason)
|
|
||||||
(raise-type-error 'parse-command-line
|
|
||||||
(format "table as a list of flag-list/procedure pairs (~a)"
|
|
||||||
reason)
|
|
||||||
table))])
|
|
||||||
(andmap
|
|
||||||
(lambda (spec)
|
|
||||||
(and (or (and (list? spec) (pair? spec))
|
|
||||||
(bad-table (format "spec-set must be a non-empty list: ~a" spec)))
|
|
||||||
(or (memq (car spec) '(once-any once-each multi final help-labels))
|
|
||||||
(bad-table (format "spec-set type must be 'once-any, 'once-each, 'multi, 'final, or 'help-labels: ~a"
|
|
||||||
(car spec))))
|
|
||||||
(andmap
|
|
||||||
(lambda (line)
|
|
||||||
(if (eq? (car spec) 'help-labels)
|
|
||||||
|
|
||||||
(or (string? line)
|
|
||||||
(bad-table (format "help-labels line must be a string: ~e" line)))
|
|
||||||
|
|
||||||
(and (or (and (list? line) (= (length line) 3))
|
|
||||||
(bad-table (format "spec-line must be a list of at three or four items: ~e" line)))
|
|
||||||
|
|
||||||
(or (list? (car line))
|
|
||||||
(bad-table (format "flags part of a spec-line must be a list: ~e" (car line))))
|
|
||||||
|
|
||||||
(andmap
|
|
||||||
(lambda (flag)
|
|
||||||
(or (string? flag)
|
|
||||||
(bad-table (format "flag must be a string: ~e" flag)))
|
|
||||||
(or (and (or (regexp-match #rx"^-[^-]$" flag)
|
|
||||||
(regexp-match #rx"^[+][^+]$" flag)
|
|
||||||
(regexp-match #rx"^--." flag)
|
|
||||||
(regexp-match #rx"^[+][+]." flag))
|
|
||||||
(not (or (regexp-match #rx"^--help$" flag)
|
|
||||||
(regexp-match #rx"^-h$" flag)
|
|
||||||
(regexp-match #rx"^[-+][0-9]*(|[.][0-9]*)$" flag))))
|
|
||||||
(bad-table (format "no ill-formed or pre-defined flags: ~e" flag))))
|
|
||||||
(car line))
|
|
||||||
|
|
||||||
(or (procedure? (cadr line))
|
|
||||||
(bad-table (format "second item in a spec-line must be a procedure: ~e" (cadr line))))
|
|
||||||
|
|
||||||
(let ([a (procedure-arity (cadr line))])
|
|
||||||
(or (and (number? a)
|
|
||||||
(or (>= a 1)
|
|
||||||
(bad-table (format "flag handler procedure must take at least 1 argument: ~e"
|
|
||||||
(cadr line)))))
|
|
||||||
(arity-at-least? a)
|
|
||||||
(bad-table (format "flag handler procedure cannot have multiple cases: ~e" (cadr line)))))
|
|
||||||
|
|
||||||
(or (let ([h (caddr line)])
|
|
||||||
(and (pair? h)
|
|
||||||
(or (string? (car h))
|
|
||||||
(andmap string? (car h)))
|
|
||||||
(andmap string? (cdr h))))
|
|
||||||
(bad-table (format "spec-line help section must be a list of string-or-string-list and strings")))
|
|
||||||
|
|
||||||
(or (let ([l (length (caddr line))]
|
|
||||||
[a (procedure-arity (cadr line))])
|
|
||||||
(if (number? a)
|
|
||||||
(= a l)
|
|
||||||
(and (>= l 1)
|
|
||||||
(>= l (arity-at-least-value a)))))
|
|
||||||
(bad-table (format "spec-line help list strings must match procedure arguments"))))))
|
|
||||||
(cdr spec))))
|
|
||||||
table)))
|
|
||||||
(raise-type-error 'parse-command-line "table of spec sets" table))
|
|
||||||
(unless (and (procedure? finish)
|
|
||||||
(procedure-arity-includes-at-least? finish 1))
|
|
||||||
(raise-type-error 'parse-command-line "finish procedure accepting at least 1 argument" finish))
|
|
||||||
(unless (and (list? finish-help) (andmap string? finish-help))
|
|
||||||
(raise-type-error 'parse-command-line "argument help list of strings" finish-help))
|
|
||||||
(unless (and (procedure? help) (procedure-arity-includes? help 1))
|
|
||||||
(raise-type-error 'parse-command-line "help procedure of arity 1" help))
|
|
||||||
(unless (and (procedure? unknown-flag) (procedure-arity-includes? unknown-flag 1)
|
|
||||||
(let ([a (procedure-arity unknown-flag)])
|
|
||||||
(or (number? a) (arity-at-least? a))))
|
|
||||||
(raise-type-error 'parse-command-line "unknown-flag procedure of simple arity, accepting 1 argument (an perhaps more)" unknown-flag))
|
|
||||||
|
|
||||||
(letrec ([a (procedure-arity finish)]
|
|
||||||
[l (length finish-help)]
|
|
||||||
[a-c (lambda (a)
|
|
||||||
(or (and (number? a) (sub1 a))
|
|
||||||
(and (arity-at-least? a)
|
|
||||||
(max 1 (arity-at-least-value a)))
|
|
||||||
(and (list? a) (apply max (map a-c a)))))])
|
|
||||||
(unless (= (a-c a) l)
|
|
||||||
(error 'parse-command-line "the length of the argument help string list does not match the arity of the finish procedure")))
|
|
||||||
|
|
||||||
(let* ([finalled? #f] ; set to true when 'once-final is seen
|
|
||||||
[once-spec-set
|
|
||||||
(lambda (lines)
|
|
||||||
(let ([set (mcons #f (apply append (map car lines)))])
|
|
||||||
(map
|
|
||||||
(lambda (line) (cons set line))
|
|
||||||
lines)))]
|
|
||||||
[first? (lambda (x lst)
|
|
||||||
(and (pair? lst) (eq? x (car lst))))]
|
|
||||||
[last? (lambda (x lst)
|
|
||||||
(and (pair? lst)
|
|
||||||
(let loop ([l lst])
|
|
||||||
(if (pair? (cdr l))
|
|
||||||
(loop (cdr l))
|
|
||||||
(eq? x (car l))))))]
|
|
||||||
[table
|
|
||||||
;; list of (list <once-set> <spec-line> ...)
|
|
||||||
;; If <once-set> is #f, then flags in <spec-line> are allowed
|
|
||||||
;; any number of times.
|
|
||||||
;; If <once-set> is 'final, then its like #f, and `finalled?' should
|
|
||||||
;; be set.
|
|
||||||
;; Otherwise, <once-set> is (mcons <bool> (list <string> ...)) where <bool>
|
|
||||||
;; starts as #f and is mutated to #t when one of <string> is
|
|
||||||
;; matched.
|
|
||||||
(apply
|
|
||||||
append
|
|
||||||
(list
|
|
||||||
(list #f
|
|
||||||
(list "--help" "-h")
|
|
||||||
(lambda (f)
|
|
||||||
(let* ([sp (open-output-string)])
|
|
||||||
(fprintf sp "~a [ <option> ... ]" program)
|
|
||||||
(print-args sp finish-help finish)
|
|
||||||
(fprintf sp "~n where <option> is one of~n")
|
|
||||||
(for-each
|
|
||||||
(lambda (set)
|
|
||||||
(if (eq? (car set) 'help-labels)
|
|
||||||
(for-each
|
|
||||||
(lambda (line)
|
|
||||||
(fprintf sp " ~a~n" line))
|
|
||||||
(cdr set))
|
|
||||||
(for-each
|
|
||||||
(lambda (line)
|
|
||||||
(let* ([helps (caaddr line)]
|
|
||||||
[helps (if (string? helps) (list helps) helps)])
|
|
||||||
(for-each
|
|
||||||
(lambda (help)
|
|
||||||
|
|
||||||
(fprintf sp
|
|
||||||
(cond [(and (eq? (car set) 'once-any)
|
|
||||||
(pair? (cddr set)))
|
|
||||||
(cond
|
|
||||||
[(and (first? line (cdr set))
|
|
||||||
(first? help helps))
|
|
||||||
"/"]
|
|
||||||
[(and (last? line (cdr set))
|
|
||||||
(last? help helps))
|
|
||||||
"\\"]
|
|
||||||
[else "|"])]
|
|
||||||
[(and (memq (car set) '(multi final))
|
|
||||||
(first? help helps))
|
|
||||||
"*"]
|
|
||||||
[else " "]))
|
|
||||||
(if (first? help helps)
|
|
||||||
(begin
|
|
||||||
(let loop ([flags (car line)])
|
|
||||||
(let ([flag (car flags)])
|
|
||||||
(fprintf sp " ~a" flag)
|
|
||||||
(print-args sp (cdaddr line) (cadr line)))
|
|
||||||
(unless (null? (cdr flags))
|
|
||||||
(fprintf sp ",")
|
|
||||||
(loop (cdr flags))))
|
|
||||||
(fprintf sp " :"))
|
|
||||||
(fprintf sp " "))
|
|
||||||
(fprintf sp " ~a~n" help))
|
|
||||||
helps)))
|
|
||||||
(cdr set))))
|
|
||||||
table) ; the original table
|
|
||||||
(fprintf sp " --help, -h : Show this help~n")
|
|
||||||
(fprintf sp " -- : Do not treat any remaining argument as a switch (at this level)~n")
|
|
||||||
(when (or (assq 'multi table) (assq 'final table))
|
|
||||||
(fprintf sp " * Asterisks indicate options allowed multiple times.~n"))
|
|
||||||
(when (assq 'once-any table)
|
|
||||||
(fprintf sp " /|\\ Brackets indicate mutually exclusive options.~n"))
|
|
||||||
(fprintf sp " Multiple single-letter switches can be combined after one `-'; for~n")
|
|
||||||
(fprintf sp " example: `-h-' is the same as `-h --'~n")
|
|
||||||
(help (get-output-string sp))))
|
|
||||||
(list "Help")))
|
|
||||||
(map
|
|
||||||
(lambda (spec)
|
|
||||||
(cond
|
|
||||||
[(eq? (car spec) 'once-each)
|
|
||||||
(apply
|
|
||||||
append
|
|
||||||
(map
|
|
||||||
(lambda (line) (once-spec-set (list line)))
|
|
||||||
(cdr spec)))]
|
|
||||||
[(eq? (car spec) 'once-any)
|
|
||||||
(once-spec-set (cdr spec))]
|
|
||||||
[(eq? (car spec) 'help-labels)
|
|
||||||
null]
|
|
||||||
[(eq? (car spec) 'multi)
|
|
||||||
(map
|
|
||||||
(lambda (line) (cons #f line))
|
|
||||||
(cdr spec))]
|
|
||||||
[(eq? (car spec) 'final)
|
|
||||||
(map
|
|
||||||
(lambda (line) (cons 'final line))
|
|
||||||
(cdr spec))]))
|
|
||||||
table))]
|
|
||||||
[done
|
|
||||||
(lambda (args r-acc)
|
|
||||||
(let ([options (reverse r-acc)]
|
|
||||||
[c (length args)])
|
|
||||||
(if (procedure-arity-includes? finish (add1 c))
|
|
||||||
(apply finish options args)
|
|
||||||
(raise-user-error (string->symbol (format "~a" program))
|
|
||||||
(format "expects~a on the command line, given ~a argument~a~a"
|
|
||||||
(if (null? finish-help)
|
|
||||||
" no arguments"
|
|
||||||
(let ([s (open-output-string)])
|
|
||||||
(parameterize ([current-output-port s])
|
|
||||||
(print-args s finish-help finish))
|
|
||||||
(let ([s (get-output-string s)])
|
|
||||||
(if (equal? 2 (procedure-arity finish))
|
|
||||||
(format " 1~a" s)
|
|
||||||
s))))
|
|
||||||
c
|
|
||||||
(cond
|
|
||||||
[(zero? c) "s"]
|
|
||||||
[(= c 1) ": "]
|
|
||||||
[else "s: "])
|
|
||||||
(let loop ([args args])
|
|
||||||
(if (null? args)
|
|
||||||
""
|
|
||||||
(string-append (car args) " " (loop (cdr args))))))))))]
|
|
||||||
[call-handler
|
|
||||||
(lambda (handler flag args r-acc k)
|
|
||||||
(let* ([a (procedure-arity handler)]
|
|
||||||
[remaining (length args)]
|
|
||||||
[needed (if (number? a)
|
|
||||||
(sub1 a)
|
|
||||||
(sub1 (arity-at-least-value a)))]
|
|
||||||
[use (if (number? a)
|
|
||||||
(sub1 a)
|
|
||||||
remaining)])
|
|
||||||
(if (< remaining needed)
|
|
||||||
(raise-user-error (string->symbol (format "~a" program))
|
|
||||||
"the ~s option needs ~a argument~a, but ~a~a provided"
|
|
||||||
flag needed (if (> needed 1) "s" "")
|
|
||||||
(if (zero? remaining) "" "only ")
|
|
||||||
remaining)
|
|
||||||
(let ([v (apply handler
|
|
||||||
flag
|
|
||||||
(let loop ([n use][args args])
|
|
||||||
(if (zero? n)
|
|
||||||
null
|
|
||||||
(cons (car args)
|
|
||||||
(loop (sub1 n) (cdr args))))))])
|
|
||||||
(k (list-tail args use)
|
|
||||||
(if (void? v)
|
|
||||||
r-acc
|
|
||||||
(cons v r-acc)))))))]
|
|
||||||
[handle-flag
|
|
||||||
(lambda (flag args r-acc orig-multi k)
|
|
||||||
(let loop ([table table])
|
|
||||||
(cond
|
|
||||||
[(null? table)
|
|
||||||
(call-handler unknown-flag flag args r-acc k)]
|
|
||||||
[(member flag (cadar table))
|
|
||||||
(when (eq? 'final (caar table))
|
|
||||||
(set! finalled? #t))
|
|
||||||
(when (mpair? (caar table))
|
|
||||||
(let ([set (caar table)])
|
|
||||||
(if (mcar set)
|
|
||||||
(let ([flags (mcdr set)])
|
|
||||||
(raise-user-error
|
|
||||||
(string->symbol (format "~a" program))
|
|
||||||
(let ([s (if (= 1 (length flags))
|
|
||||||
(format "the ~a option can only be specified once" (car flags))
|
|
||||||
(format "only one instance of one option from ~a is allowed" flags))])
|
|
||||||
(if orig-multi
|
|
||||||
(format "~a; note that ~s is shorthand for ~s, in contrast to ~s"
|
|
||||||
s
|
|
||||||
orig-multi
|
|
||||||
(let loop ([prefix (string-ref orig-multi 0)]
|
|
||||||
[flags (string->list (substring orig-multi 1 (string-length orig-multi)))]
|
|
||||||
[sep ""])
|
|
||||||
(if (null? flags)
|
|
||||||
""
|
|
||||||
(format "~a~a~a~a" sep prefix (car flags)
|
|
||||||
(loop prefix (cdr flags) " "))))
|
|
||||||
(string-append (substring orig-multi 0 1) orig-multi))
|
|
||||||
s))))
|
|
||||||
(set-mcar! set #t))))
|
|
||||||
(call-handler (caddar table) flag args r-acc k)]
|
|
||||||
[else (loop (cdr table))])))])
|
|
||||||
(let loop ([args arguments][r-acc null])
|
|
||||||
(if (null? args)
|
|
||||||
(done args r-acc)
|
|
||||||
(let ([arg (car args)]
|
|
||||||
[rest (cdr args)])
|
|
||||||
(cond
|
|
||||||
[finalled?
|
|
||||||
(done args r-acc)]
|
|
||||||
[(regexp-match #rx"^[-+][0-9]*(|[.][0-9]*)$" arg)
|
|
||||||
(done args r-acc)]
|
|
||||||
[(regexp-match "^--$" arg)
|
|
||||||
(done (cdr args) r-acc)]
|
|
||||||
[(regexp-match "^[-+][-+]" arg)
|
|
||||||
(handle-flag arg rest r-acc #f loop)]
|
|
||||||
[(regexp-match "^[-+]." arg)
|
|
||||||
(let a-loop ([s (string->list (substring arg 1 (string-length arg)))]
|
|
||||||
[rest rest]
|
|
||||||
[r-acc r-acc])
|
|
||||||
(if (null? s)
|
|
||||||
(loop rest r-acc)
|
|
||||||
(handle-flag (string (string-ref arg 0) (car s))
|
|
||||||
rest r-acc
|
|
||||||
arg
|
|
||||||
(lambda (args r-acc)
|
|
||||||
(a-loop (cdr s) args r-acc)))))]
|
|
||||||
[else
|
|
||||||
(done args r-acc)])))))]))
|
|
||||||
|
|
||||||
(provide command-line parse-command-line))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,5 +1,550 @@
|
||||||
#lang scheme/base
|
#lang scheme/base
|
||||||
|
|
||||||
(require mzlib/cmdline)
|
(require (for-syntax scheme/base))
|
||||||
(provide (all-from-out mzlib/cmdline))
|
|
||||||
|
|
||||||
|
(provide command-line parse-command-line)
|
||||||
|
|
||||||
|
(define-syntax (command-line stx)
|
||||||
|
(define (id=? x y)
|
||||||
|
(eq? (syntax-e x) (syntax-e y)))
|
||||||
|
(define (serror msg . detail)
|
||||||
|
(apply raise-syntax-error #f msg stx detail))
|
||||||
|
(define (extract-one what args . detail)
|
||||||
|
(if (null? args)
|
||||||
|
(apply serror (format "missing ~a" what) detail)
|
||||||
|
(values (car args) (cdr args))))
|
||||||
|
(define (extract-list stx/list pred)
|
||||||
|
(let loop ([xs null]
|
||||||
|
[rest (if (syntax? stx/list) (syntax->list stx/list) stx/list)])
|
||||||
|
(if (and (pair? rest) (pred (car rest)))
|
||||||
|
(loop (cons (car rest) xs) (cdr rest))
|
||||||
|
(values (reverse xs) rest))))
|
||||||
|
(define (formal-names l)
|
||||||
|
(map (lambda (a)
|
||||||
|
(datum->syntax
|
||||||
|
(quote-syntax here)
|
||||||
|
(let ([s (symbol->string (syntax-e a))])
|
||||||
|
(if (char=? #\* (string-ref s (sub1 (string-length s))))
|
||||||
|
(substring s 0 (sub1 (string-length s)))
|
||||||
|
s))
|
||||||
|
#f))
|
||||||
|
l))
|
||||||
|
(define (extract-arg kw lst default)
|
||||||
|
(if (and (pair? lst)
|
||||||
|
(eq? kw (syntax-e (car lst))))
|
||||||
|
(if (null? (cdr lst))
|
||||||
|
(serror (format "missing expression for ~a" kw) (car lst))
|
||||||
|
(values (cadr lst) (cddr lst)))
|
||||||
|
(values default lst)))
|
||||||
|
(define (up-to-next-keyword lst)
|
||||||
|
(cond
|
||||||
|
[(null? lst) null]
|
||||||
|
[(keyword? (syntax-e (car lst))) null]
|
||||||
|
[else (cons (car lst) (up-to-next-keyword (cdr lst)))]))
|
||||||
|
(define (at-next-keyword lst)
|
||||||
|
(cond
|
||||||
|
[(null? lst) null]
|
||||||
|
[(keyword? (syntax-e (car lst))) lst]
|
||||||
|
[else (at-next-keyword (cdr lst))]))
|
||||||
|
(let ([lst (syntax->list stx)])
|
||||||
|
(unless lst
|
||||||
|
(raise-syntax-error #f "bad syntax (misued of `.')" stx))
|
||||||
|
(let*-values ([(lst) (cdr lst)]
|
||||||
|
[(prog-name-expr lst)
|
||||||
|
(extract-arg '#:program lst #'(find-system-path 'run-file))]
|
||||||
|
[(argv-expr lst)
|
||||||
|
(extract-arg '#:argv lst #'(current-command-line-arguments))])
|
||||||
|
(let-values ([(table args)
|
||||||
|
(let loop ([lst lst][accum null])
|
||||||
|
(if (null? lst)
|
||||||
|
(loop (syntax->list #'(#:args () (void))) accum)
|
||||||
|
(let ([a (syntax-e (car lst))]
|
||||||
|
[pieces (up-to-next-keyword (cdr lst))])
|
||||||
|
(case a
|
||||||
|
[(#:help-labels)
|
||||||
|
(for-each (lambda (x)
|
||||||
|
(unless (string? (syntax-e x))
|
||||||
|
(serror "#:help-labels clause contains non-string"
|
||||||
|
x)))
|
||||||
|
pieces)
|
||||||
|
(loop (at-next-keyword (cdr lst))
|
||||||
|
(cons (cons (quote-syntax 'help-labels) pieces)
|
||||||
|
accum))]
|
||||||
|
[(#:once-each #:once-any #:multi #:final)
|
||||||
|
(let ([sublines
|
||||||
|
(let slloop ([sublines pieces])
|
||||||
|
(if (null? sublines)
|
||||||
|
#'()
|
||||||
|
(with-syntax ([looped (slloop (cdr sublines))]
|
||||||
|
[subline
|
||||||
|
(with-syntax
|
||||||
|
([flags
|
||||||
|
(syntax-case (car sublines) ()
|
||||||
|
[((flag ...) . rest)
|
||||||
|
(begin
|
||||||
|
(unless (andmap
|
||||||
|
(lambda (x) (string? (syntax-e x)))
|
||||||
|
(syntax->list #'(flag ...)))
|
||||||
|
(serror
|
||||||
|
"flag specification is not a string or sequence of strings"
|
||||||
|
#'(flag ...)))
|
||||||
|
#'(flag ...))]
|
||||||
|
[(flag . rest)
|
||||||
|
(string? (syntax-e #'flag))
|
||||||
|
#'(flag)]
|
||||||
|
[else
|
||||||
|
(serror "clause does not start with flags")])])
|
||||||
|
(syntax-case* (car sublines) (=>) id=?
|
||||||
|
[(_ => a b)
|
||||||
|
#'(list 'flags a b)]
|
||||||
|
[(_ rest ...)
|
||||||
|
(let*-values ([(formals rest)
|
||||||
|
(extract-list #'(rest ...) identifier?)]
|
||||||
|
[(helps rest)
|
||||||
|
(cond
|
||||||
|
[(not (pair? rest))
|
||||||
|
(serror "missing help string(s)" (car sublines))]
|
||||||
|
[(string? (syntax-e (car rest)))
|
||||||
|
(values (list (car rest)) (cdr rest))]
|
||||||
|
[(syntax->list (car rest))
|
||||||
|
=> (lambda (l)
|
||||||
|
(values l (cdr rest)))]
|
||||||
|
[else
|
||||||
|
(serror "missing help string(s)" (car sublines))])]
|
||||||
|
[(expr1 rest)
|
||||||
|
(extract-one
|
||||||
|
"handler body expressions" rest (car sublines))])
|
||||||
|
(with-syntax ([formals formals]
|
||||||
|
[formal-names (formal-names formals)]
|
||||||
|
[helps helps]
|
||||||
|
[expr1 expr1]
|
||||||
|
[rest rest])
|
||||||
|
#'(list 'flags
|
||||||
|
(lambda (flag . formals) expr1 . rest)
|
||||||
|
(cons (list . helps) 'formal-names))))]))])
|
||||||
|
#'(subline . looped))))])
|
||||||
|
(loop (at-next-keyword (cdr lst))
|
||||||
|
(cons (list* #'list
|
||||||
|
#`(quote #,(string->symbol (keyword->string a)))
|
||||||
|
sublines)
|
||||||
|
accum)))]
|
||||||
|
[(#:args)
|
||||||
|
(when (null? pieces)
|
||||||
|
(serror "#:args clause missing formals" (car lst)))
|
||||||
|
(let ([formal-names
|
||||||
|
(let loop ([f (car pieces)])
|
||||||
|
(syntax-case f ()
|
||||||
|
[() null]
|
||||||
|
[(arg . rest)
|
||||||
|
(identifier? #'arg)
|
||||||
|
(cons #'arg (loop #'rest))]
|
||||||
|
[arg
|
||||||
|
(identifier? #'arg)
|
||||||
|
(list #'arg)]
|
||||||
|
[else
|
||||||
|
(serror "bad formals for #:args" (car pieces))]))])
|
||||||
|
(when (null? (cdr pieces))
|
||||||
|
(serror "#:args clause missing body after formals" (car lst)))
|
||||||
|
(unless (null? (at-next-keyword (cdr lst)))
|
||||||
|
(serror "#:args must not be followed by another keyword" (car lst)))
|
||||||
|
(with-syntax ([formals (car pieces)]
|
||||||
|
[formal-names (map (lambda (x)
|
||||||
|
(symbol->string (syntax-e x)))
|
||||||
|
formal-names)]
|
||||||
|
[body (cdr pieces)])
|
||||||
|
(values (reverse accum)
|
||||||
|
(list #'(lambda (accume . formals) . body)
|
||||||
|
(syntax 'formal-names)))))]
|
||||||
|
[(#:handlers)
|
||||||
|
(let ([len (length pieces)])
|
||||||
|
(when (len . < . 1)
|
||||||
|
(serror "missing finish-proc expression for #:handlers" (car lst)))
|
||||||
|
(when (len . < . 2)
|
||||||
|
(serror "missing arg-strings expression for #:handlers" (car lst)))
|
||||||
|
(when (len . > . 4)
|
||||||
|
(let ([e (list-ref pieces 4)])
|
||||||
|
(if (keyword? (syntax-e e))
|
||||||
|
(serror "#:handlers must not be followed by another keyword" e)
|
||||||
|
(serror "unexpected expression for #:handlers" e)))))
|
||||||
|
(values (reverse accum) pieces)]
|
||||||
|
[else
|
||||||
|
(serror "expected a clause keyword, such as #:multi or #:args" (car lst))]))))])
|
||||||
|
(with-syntax ([program-name prog-name-expr]
|
||||||
|
[argv argv-expr]
|
||||||
|
[table table]
|
||||||
|
[args args])
|
||||||
|
#'(parse-command-line program-name argv (list . table) . args))))))
|
||||||
|
|
||||||
|
(define print-args
|
||||||
|
(lambda (port l f)
|
||||||
|
(let loop ([l l][a (letrec ([a (procedure-arity f)]
|
||||||
|
[a-c (lambda (a)
|
||||||
|
(cond
|
||||||
|
[(number? a) (cons (sub1 a) (sub1 a))]
|
||||||
|
[(arity-at-least? a)
|
||||||
|
(let ([v (sub1 (arity-at-least-value a))])
|
||||||
|
(cons v v))]
|
||||||
|
[else (let ([r (map a-c a)])
|
||||||
|
(cons (apply min (map car r))
|
||||||
|
(apply max (map cdr r))))]))])
|
||||||
|
(a-c a))])
|
||||||
|
(unless (null? l)
|
||||||
|
(fprintf port " ~a<~a>~a"
|
||||||
|
(if (positive? (car a)) "" "[")
|
||||||
|
(car l)
|
||||||
|
(if (positive? (car a)) "" "]"))
|
||||||
|
(unless (positive? (cdr a))
|
||||||
|
(fprintf port " ..."))
|
||||||
|
(loop (cdr l) (cons (sub1 (car a)) (sub1 (cdr a))))))))
|
||||||
|
|
||||||
|
(define (procedure-arity-includes-at-least? p n)
|
||||||
|
(letrec ([a-c
|
||||||
|
(lambda (a)
|
||||||
|
(cond
|
||||||
|
[(number? a) (>= a n)]
|
||||||
|
[(arity-at-least? a) #t]
|
||||||
|
[else (ormap a-c a)]))])
|
||||||
|
(a-c (procedure-arity p))))
|
||||||
|
|
||||||
|
(define (program-name program)
|
||||||
|
(if (path? program)
|
||||||
|
(let-values ([(base name dir?) (split-path program)])
|
||||||
|
(if (path? name)
|
||||||
|
(path-element->string name)
|
||||||
|
(path->string program)))
|
||||||
|
program))
|
||||||
|
|
||||||
|
(define parse-command-line
|
||||||
|
(case-lambda
|
||||||
|
[(program arguments table finish finish-help)
|
||||||
|
(parse-command-line program arguments table finish finish-help
|
||||||
|
(lambda (s)
|
||||||
|
(display s)
|
||||||
|
(exit 0)))]
|
||||||
|
[(program arguments table finish finish-help help)
|
||||||
|
(parse-command-line program arguments table finish finish-help help
|
||||||
|
(lambda (flag)
|
||||||
|
(raise-user-error (string->symbol (program-name program))
|
||||||
|
"unknown switch: ~a" flag)))]
|
||||||
|
[(program arguments0 table finish finish-help help unknown-flag)
|
||||||
|
(define arguments (if (vector? arguments0) (vector->list arguments0) arguments0))
|
||||||
|
(unless (or (string? program) (path? program))
|
||||||
|
(raise-type-error 'parse-command-line "program name string" program))
|
||||||
|
(unless (and (list? arguments)
|
||||||
|
(andmap string? arguments))
|
||||||
|
(raise-type-error 'parse-command-line "argument vector/list of strings" arguments0))
|
||||||
|
(unless (and (list? table)
|
||||||
|
(let ([bad-table
|
||||||
|
(lambda (reason)
|
||||||
|
(raise-type-error 'parse-command-line
|
||||||
|
(format "table as a list of flag-list/procedure pairs (~a)"
|
||||||
|
reason)
|
||||||
|
table))])
|
||||||
|
(andmap
|
||||||
|
(lambda (spec)
|
||||||
|
(and (or (and (list? spec) (pair? spec))
|
||||||
|
(bad-table (format "spec-set must be a non-empty list: ~a" spec)))
|
||||||
|
(or (memq (car spec) '(once-any once-each multi final help-labels))
|
||||||
|
(bad-table (format "spec-set type must be 'once-any, 'once-each, 'multi, 'final, or 'help-labels: ~a"
|
||||||
|
(car spec))))
|
||||||
|
(andmap
|
||||||
|
(lambda (line)
|
||||||
|
(if (eq? (car spec) 'help-labels)
|
||||||
|
|
||||||
|
(or (string? line)
|
||||||
|
(bad-table (format "help-labels line must be a string: ~e" line)))
|
||||||
|
|
||||||
|
(and (or (and (list? line) (= (length line) 3))
|
||||||
|
(bad-table (format "spec-line must be a list of at three or four items: ~e" line)))
|
||||||
|
|
||||||
|
(or (list? (car line))
|
||||||
|
(bad-table (format "flags part of a spec-line must be a list: ~e" (car line))))
|
||||||
|
|
||||||
|
(andmap
|
||||||
|
(lambda (flag)
|
||||||
|
(or (string? flag)
|
||||||
|
(bad-table (format "flag must be a string: ~e" flag)))
|
||||||
|
(or (and (or (regexp-match #rx"^-[^-]$" flag)
|
||||||
|
(regexp-match #rx"^[+][^+]$" flag)
|
||||||
|
(regexp-match #rx"^--." flag)
|
||||||
|
(regexp-match #rx"^[+][+]." flag))
|
||||||
|
(not (or (regexp-match #rx"^--help$" flag)
|
||||||
|
(regexp-match #rx"^-h$" flag)
|
||||||
|
(regexp-match #rx"^[-+][0-9]*(|[.][0-9]*)$" flag))))
|
||||||
|
(bad-table (format "no ill-formed or pre-defined flags: ~e" flag))))
|
||||||
|
(car line))
|
||||||
|
|
||||||
|
(or (procedure? (cadr line))
|
||||||
|
(bad-table (format "second item in a spec-line must be a procedure: ~e" (cadr line))))
|
||||||
|
|
||||||
|
(let ([a (procedure-arity (cadr line))])
|
||||||
|
(or (and (number? a)
|
||||||
|
(or (>= a 1)
|
||||||
|
(bad-table (format "flag handler procedure must take at least 1 argument: ~e"
|
||||||
|
(cadr line)))))
|
||||||
|
(arity-at-least? a)
|
||||||
|
(bad-table (format "flag handler procedure cannot have multiple cases: ~e" (cadr line)))))
|
||||||
|
|
||||||
|
(or (let ([h (caddr line)])
|
||||||
|
(and (pair? h)
|
||||||
|
(or (string? (car h))
|
||||||
|
(andmap string? (car h)))
|
||||||
|
(andmap string? (cdr h))))
|
||||||
|
(bad-table (format "spec-line help section must be a list of string-or-string-list and strings")))
|
||||||
|
|
||||||
|
(or (let ([l (length (caddr line))]
|
||||||
|
[a (procedure-arity (cadr line))])
|
||||||
|
(if (number? a)
|
||||||
|
(= a l)
|
||||||
|
(and (>= l 1)
|
||||||
|
(>= l (arity-at-least-value a)))))
|
||||||
|
(bad-table (format "spec-line help list strings must match procedure arguments"))))))
|
||||||
|
(cdr spec))))
|
||||||
|
table)))
|
||||||
|
(raise-type-error 'parse-command-line "table of spec sets" table))
|
||||||
|
(unless (and (procedure? finish)
|
||||||
|
(procedure-arity-includes-at-least? finish 1))
|
||||||
|
(raise-type-error 'parse-command-line "finish procedure accepting at least 1 argument" finish))
|
||||||
|
(unless (and (list? finish-help) (andmap string? finish-help))
|
||||||
|
(raise-type-error 'parse-command-line "argument help list of strings" finish-help))
|
||||||
|
(unless (and (procedure? help) (procedure-arity-includes? help 1))
|
||||||
|
(raise-type-error 'parse-command-line "help procedure of arity 1" help))
|
||||||
|
(unless (and (procedure? unknown-flag) (procedure-arity-includes? unknown-flag 1)
|
||||||
|
(let ([a (procedure-arity unknown-flag)])
|
||||||
|
(or (number? a) (arity-at-least? a))))
|
||||||
|
(raise-type-error 'parse-command-line "unknown-flag procedure of simple arity, accepting 1 argument (an perhaps more)" unknown-flag))
|
||||||
|
|
||||||
|
(letrec ([a (procedure-arity finish)]
|
||||||
|
[l (length finish-help)]
|
||||||
|
[a-c (lambda (a)
|
||||||
|
(or (and (number? a) (sub1 a))
|
||||||
|
(and (arity-at-least? a)
|
||||||
|
(max 1 (arity-at-least-value a)))
|
||||||
|
(and (list? a) (apply max (map a-c a)))))])
|
||||||
|
(unless (= (a-c a) l)
|
||||||
|
(error 'parse-command-line "the length of the argument help string list does not match the arity of the finish procedure")))
|
||||||
|
|
||||||
|
(let* ([finalled? #f] ; set to true when 'once-final is seen
|
||||||
|
[once-spec-set
|
||||||
|
(lambda (lines)
|
||||||
|
(let ([set (mcons #f (apply append (map car lines)))])
|
||||||
|
(map
|
||||||
|
(lambda (line) (cons set line))
|
||||||
|
lines)))]
|
||||||
|
[first? (lambda (x lst)
|
||||||
|
(and (pair? lst) (eq? x (car lst))))]
|
||||||
|
[last? (lambda (x lst)
|
||||||
|
(and (pair? lst)
|
||||||
|
(let loop ([l lst])
|
||||||
|
(if (pair? (cdr l))
|
||||||
|
(loop (cdr l))
|
||||||
|
(eq? x (car l))))))]
|
||||||
|
[table
|
||||||
|
;; list of (list <once-set> <spec-line> ...)
|
||||||
|
;; If <once-set> is #f, then flags in <spec-line> are allowed
|
||||||
|
;; any number of times.
|
||||||
|
;; If <once-set> is 'final, then its like #f, and `finalled?' should
|
||||||
|
;; be set.
|
||||||
|
;; Otherwise, <once-set> is (mcons <bool> (list <string> ...)) where <bool>
|
||||||
|
;; starts as #f and is mutated to #t when one of <string> is
|
||||||
|
;; matched.
|
||||||
|
(apply
|
||||||
|
append
|
||||||
|
(list
|
||||||
|
(list #f
|
||||||
|
(list "--help" "-h")
|
||||||
|
(lambda (f)
|
||||||
|
(let* ([sp (open-output-string)])
|
||||||
|
(fprintf sp "~a [ <option> ... ]" (program-name program))
|
||||||
|
(print-args sp finish-help finish)
|
||||||
|
(fprintf sp "~n where <option> is one of~n")
|
||||||
|
(for-each
|
||||||
|
(lambda (set)
|
||||||
|
(if (eq? (car set) 'help-labels)
|
||||||
|
(for-each
|
||||||
|
(lambda (line)
|
||||||
|
(fprintf sp " ~a~n" line))
|
||||||
|
(cdr set))
|
||||||
|
(for-each
|
||||||
|
(lambda (line)
|
||||||
|
(let* ([helps (caaddr line)]
|
||||||
|
[helps (if (string? helps) (list helps) helps)])
|
||||||
|
(for-each
|
||||||
|
(lambda (help)
|
||||||
|
|
||||||
|
(fprintf sp
|
||||||
|
(cond [(and (eq? (car set) 'once-any)
|
||||||
|
(pair? (cddr set)))
|
||||||
|
(cond
|
||||||
|
[(and (first? line (cdr set))
|
||||||
|
(first? help helps))
|
||||||
|
"/"]
|
||||||
|
[(and (last? line (cdr set))
|
||||||
|
(last? help helps))
|
||||||
|
"\\"]
|
||||||
|
[else "|"])]
|
||||||
|
[(and (memq (car set) '(multi final))
|
||||||
|
(first? help helps))
|
||||||
|
"*"]
|
||||||
|
[else " "]))
|
||||||
|
(if (first? help helps)
|
||||||
|
(begin
|
||||||
|
(let loop ([flags (car line)])
|
||||||
|
(let ([flag (car flags)])
|
||||||
|
(fprintf sp " ~a" flag)
|
||||||
|
(print-args sp (cdaddr line) (cadr line)))
|
||||||
|
(unless (null? (cdr flags))
|
||||||
|
(fprintf sp ",")
|
||||||
|
(loop (cdr flags))))
|
||||||
|
(fprintf sp " :"))
|
||||||
|
(fprintf sp " "))
|
||||||
|
(fprintf sp " ~a~n" help))
|
||||||
|
helps)))
|
||||||
|
(cdr set))))
|
||||||
|
table) ; the original table
|
||||||
|
(fprintf sp " --help, -h : Show this help~n")
|
||||||
|
(fprintf sp " -- : Do not treat any remaining argument as a switch (at this level)~n")
|
||||||
|
(when (or (assq 'multi table) (assq 'final table))
|
||||||
|
(fprintf sp " * Asterisks indicate options allowed multiple times.~n"))
|
||||||
|
(when (assq 'once-any table)
|
||||||
|
(fprintf sp " /|\\ Brackets indicate mutually exclusive options.~n"))
|
||||||
|
(fprintf sp " Multiple single-letter switches can be combined after one `-'; for~n")
|
||||||
|
(fprintf sp " example: `-h-' is the same as `-h --'~n")
|
||||||
|
(help (get-output-string sp))))
|
||||||
|
(list "Help")))
|
||||||
|
(map
|
||||||
|
(lambda (spec)
|
||||||
|
(cond
|
||||||
|
[(eq? (car spec) 'once-each)
|
||||||
|
(apply
|
||||||
|
append
|
||||||
|
(map
|
||||||
|
(lambda (line) (once-spec-set (list line)))
|
||||||
|
(cdr spec)))]
|
||||||
|
[(eq? (car spec) 'once-any)
|
||||||
|
(once-spec-set (cdr spec))]
|
||||||
|
[(eq? (car spec) 'help-labels)
|
||||||
|
null]
|
||||||
|
[(eq? (car spec) 'multi)
|
||||||
|
(map
|
||||||
|
(lambda (line) (cons #f line))
|
||||||
|
(cdr spec))]
|
||||||
|
[(eq? (car spec) 'final)
|
||||||
|
(map
|
||||||
|
(lambda (line) (cons 'final line))
|
||||||
|
(cdr spec))]))
|
||||||
|
table))]
|
||||||
|
[done
|
||||||
|
(lambda (args r-acc)
|
||||||
|
(let ([options (reverse r-acc)]
|
||||||
|
[c (length args)])
|
||||||
|
(if (procedure-arity-includes? finish (add1 c))
|
||||||
|
(apply finish options args)
|
||||||
|
(raise-user-error (string->symbol (program-name program))
|
||||||
|
(format "expects~a on the command line, given ~a argument~a~a"
|
||||||
|
(if (null? finish-help)
|
||||||
|
" no arguments"
|
||||||
|
(let ([s (open-output-string)])
|
||||||
|
(parameterize ([current-output-port s])
|
||||||
|
(print-args s finish-help finish))
|
||||||
|
(let ([s (get-output-string s)])
|
||||||
|
(if (equal? 2 (procedure-arity finish))
|
||||||
|
(format " 1~a" s)
|
||||||
|
s))))
|
||||||
|
c
|
||||||
|
(cond
|
||||||
|
[(zero? c) "s"]
|
||||||
|
[(= c 1) ": "]
|
||||||
|
[else "s: "])
|
||||||
|
(let loop ([args args])
|
||||||
|
(if (null? args)
|
||||||
|
""
|
||||||
|
(string-append (car args) " " (loop (cdr args))))))))))]
|
||||||
|
[call-handler
|
||||||
|
(lambda (handler flag args r-acc k)
|
||||||
|
(let* ([a (procedure-arity handler)]
|
||||||
|
[remaining (length args)]
|
||||||
|
[needed (if (number? a)
|
||||||
|
(sub1 a)
|
||||||
|
(sub1 (arity-at-least-value a)))]
|
||||||
|
[use (if (number? a)
|
||||||
|
(sub1 a)
|
||||||
|
remaining)])
|
||||||
|
(if (< remaining needed)
|
||||||
|
(raise-user-error (string->symbol (program-name program))
|
||||||
|
"the ~s option needs ~a argument~a, but ~a~a provided"
|
||||||
|
flag needed (if (> needed 1) "s" "")
|
||||||
|
(if (zero? remaining) "" "only ")
|
||||||
|
remaining)
|
||||||
|
(let ([v (apply handler
|
||||||
|
flag
|
||||||
|
(let loop ([n use][args args])
|
||||||
|
(if (zero? n)
|
||||||
|
null
|
||||||
|
(cons (car args)
|
||||||
|
(loop (sub1 n) (cdr args))))))])
|
||||||
|
(k (list-tail args use)
|
||||||
|
(if (void? v)
|
||||||
|
r-acc
|
||||||
|
(cons v r-acc)))))))]
|
||||||
|
[handle-flag
|
||||||
|
(lambda (flag args r-acc orig-multi k)
|
||||||
|
(let loop ([table table])
|
||||||
|
(cond
|
||||||
|
[(null? table)
|
||||||
|
(call-handler unknown-flag flag args r-acc k)]
|
||||||
|
[(member flag (cadar table))
|
||||||
|
(when (eq? 'final (caar table))
|
||||||
|
(set! finalled? #t))
|
||||||
|
(when (mpair? (caar table))
|
||||||
|
(let ([set (caar table)])
|
||||||
|
(if (mcar set)
|
||||||
|
(let ([flags (mcdr set)])
|
||||||
|
(raise-user-error
|
||||||
|
(string->symbol (program-name program))
|
||||||
|
(let ([s (if (= 1 (length flags))
|
||||||
|
(format "the ~a option can only be specified once" (car flags))
|
||||||
|
(format "only one instance of one option from ~a is allowed" flags))])
|
||||||
|
(if orig-multi
|
||||||
|
(format "~a; note that ~s is shorthand for ~s, in contrast to ~s"
|
||||||
|
s
|
||||||
|
orig-multi
|
||||||
|
(let loop ([prefix (string-ref orig-multi 0)]
|
||||||
|
[flags (string->list (substring orig-multi 1 (string-length orig-multi)))]
|
||||||
|
[sep ""])
|
||||||
|
(if (null? flags)
|
||||||
|
""
|
||||||
|
(format "~a~a~a~a" sep prefix (car flags)
|
||||||
|
(loop prefix (cdr flags) " "))))
|
||||||
|
(string-append (substring orig-multi 0 1) orig-multi))
|
||||||
|
s))))
|
||||||
|
(set-mcar! set #t))))
|
||||||
|
(call-handler (caddar table) flag args r-acc k)]
|
||||||
|
[else (loop (cdr table))])))])
|
||||||
|
(let loop ([args arguments][r-acc null])
|
||||||
|
(if (null? args)
|
||||||
|
(done args r-acc)
|
||||||
|
(let ([arg (car args)]
|
||||||
|
[rest (cdr args)])
|
||||||
|
(cond
|
||||||
|
[finalled?
|
||||||
|
(done args r-acc)]
|
||||||
|
[(regexp-match #rx"^[-+][0-9]*(|[.][0-9]*)$" arg)
|
||||||
|
(done args r-acc)]
|
||||||
|
[(regexp-match "^--$" arg)
|
||||||
|
(done (cdr args) r-acc)]
|
||||||
|
[(regexp-match "^[-+][-+]" arg)
|
||||||
|
(handle-flag arg rest r-acc #f loop)]
|
||||||
|
[(regexp-match "^[-+]." arg)
|
||||||
|
(let a-loop ([s (string->list (substring arg 1 (string-length arg)))]
|
||||||
|
[rest rest]
|
||||||
|
[r-acc r-acc])
|
||||||
|
(if (null? s)
|
||||||
|
(loop rest r-acc)
|
||||||
|
(handle-flag (string (string-ref arg 0) (car s))
|
||||||
|
rest r-acc
|
||||||
|
arg
|
||||||
|
(lambda (args r-acc)
|
||||||
|
(a-loop (cdr s) args r-acc)))))]
|
||||||
|
[else
|
||||||
|
(done args r-acc)])))))]))
|
||||||
|
|
|
||||||
|
|
@ -11,6 +11,7 @@
|
||||||
scheme/list
|
scheme/list
|
||||||
scheme/path
|
scheme/path
|
||||||
scheme/file
|
scheme/file
|
||||||
|
scheme/cmdline
|
||||||
(for-syntax scheme/base))
|
(for-syntax scheme/base))
|
||||||
|
|
||||||
(provide (all-from-out scheme/contract
|
(provide (all-from-out scheme/contract
|
||||||
|
|
@ -25,5 +26,6 @@
|
||||||
scheme/udp
|
scheme/udp
|
||||||
scheme/list
|
scheme/list
|
||||||
scheme/path
|
scheme/path
|
||||||
scheme/file)
|
scheme/file
|
||||||
|
scheme/cmdline)
|
||||||
(for-syntax (all-from-out scheme/base))))
|
(for-syntax (all-from-out scheme/base))))
|
||||||
|
|
|
||||||
|
|
@ -11,3 +11,4 @@
|
||||||
@include-section["subprocess.scrbl"]
|
@include-section["subprocess.scrbl"]
|
||||||
@include-section["time.scrbl"]
|
@include-section["time.scrbl"]
|
||||||
@include-section["runtime.scrbl"]
|
@include-section["runtime.scrbl"]
|
||||||
|
@include-section["cmdline.scrbl"]
|
||||||
|
|
|
||||||
|
|
@ -3,8 +3,8 @@
|
||||||
;; both in setup.ss (pre-zo, pre-cm) and setup-go.ss (use zos and cm).
|
;; both in setup.ss (pre-zo, pre-cm) and setup-go.ss (use zos and cm).
|
||||||
;; This means that command lines will be parsed twice.
|
;; This means that command lines will be parsed twice.
|
||||||
|
|
||||||
(module setup-cmdline mzscheme
|
(module setup-cmdline scheme/base
|
||||||
(require (lib "cmdline.ss"))
|
(require scheme/cmdline)
|
||||||
|
|
||||||
(provide parse-cmdline)
|
(provide parse-cmdline)
|
||||||
|
|
||||||
|
|
@ -24,71 +24,70 @@
|
||||||
|
|
||||||
(define-values (x-specific-collections x-archives)
|
(define-values (x-specific-collections x-archives)
|
||||||
(command-line
|
(command-line
|
||||||
"setup-plt"
|
#:argv argv
|
||||||
argv
|
#:once-each
|
||||||
(multi
|
[("-c" "--clean") "Delete existing compiled files; implies -nxi"
|
||||||
[("-P") owner package-name maj min
|
(add-flags '((clean #t)
|
||||||
"Setup specified PLaneT packages only"
|
(make-zo #f)
|
||||||
(set!
|
(call-install #f)
|
||||||
x-specific-planet-packages
|
(make-launchers #f)
|
||||||
(cons (list owner package-name maj min) x-specific-planet-packages))])
|
(make-info-domain #f)
|
||||||
(once-each
|
(make-docs #f)))]
|
||||||
[("-c" "--clean") "Delete existing compiled files; implies -nxi"
|
[("-n" "--no-zo") "Do not produce .zo files"
|
||||||
(add-flags '((clean #t)
|
(add-flags '((make-zo #f)))]
|
||||||
(make-zo #f)
|
[("-x" "--no-launcher") "Do not produce launcher programs"
|
||||||
(call-install #f)
|
(add-flags '((make-launchers #f)))]
|
||||||
(make-launchers #f)
|
[("-i" "--no-install") "Do not call collection-specific pre-installers"
|
||||||
(make-info-domain #f)
|
(add-flags '((call-install #f)))]
|
||||||
(make-docs #f)))]
|
[("-I" "--no-post-install") "Do not call collection-specific post-installers"
|
||||||
[("-n" "--no-zo") "Do not produce .zo files"
|
(add-flags '((call-post-install #f)))]
|
||||||
(add-flags '((make-zo #f)))]
|
[("-d" "--no-info-domain") "Do not produce info-domain caches"
|
||||||
[("-x" "--no-launcher") "Do not produce launcher programs"
|
(add-flags '((make-info-domain #f)))]
|
||||||
(add-flags '((make-launchers #f)))]
|
[("-D" "--no-docs") "Do not produce documentation"
|
||||||
[("-i" "--no-install") "Do not call collection-specific pre-installers"
|
(add-flags '((make-docs #f)))]
|
||||||
(add-flags '((call-install #f)))]
|
[("--no-planet") "Do not setup PLaneT packages"
|
||||||
[("-I" "--no-post-install") "Do not call collection-specific post-installers"
|
(add-flags '((make-planet #f)))]
|
||||||
(add-flags '((call-post-install #f)))]
|
[("-e" "--extension") "Produce native code extensions"
|
||||||
[("-d" "--no-info-domain") "Do not produce info-domain caches"
|
(add-flags '((make-so #t)))]
|
||||||
(add-flags '((make-info-domain #f)))]
|
[("-v" "--verbose") "See names of compiled files and info printfs"
|
||||||
[("-D" "--no-docs") "Do not produce documentation"
|
(add-flags '((verbose #t)))]
|
||||||
(add-flags '((make-docs #f)))]
|
[("-m" "--make-verbose") "See make and compiler usual messages"
|
||||||
[("--no-planet") "Do not setup PLaneT packages"
|
(add-flags '((make-verbose #t)))]
|
||||||
(add-flags '((make-planet #f)))]
|
[("-r" "--compile-verbose") "See make and compiler verbose messages"
|
||||||
[("-e" "--extension") "Produce native code extensions"
|
(add-flags '((make-verbose #t)
|
||||||
(add-flags '((make-so #t)))]
|
(compiler-verbose #t)))]
|
||||||
[("-v" "--verbose") "See names of compiled files and info printfs"
|
[("--trust-zos") "Trust existing .zos (use only with prepackaged .zos)"
|
||||||
(add-flags '((verbose #t)))]
|
(add-flags '((trust-existing-zos #t)))]
|
||||||
[("-m" "--make-verbose") "See make and compiler usual messages"
|
[("-p" "--pause") "Pause at the end if there are any errors"
|
||||||
(add-flags '((make-verbose #t)))]
|
(add-flags '((pause-on-errors #t)))]
|
||||||
[("-r" "--compile-verbose") "See make and compiler verbose messages"
|
[("--force") "Treat version mismatches for archives as mere warnings"
|
||||||
(add-flags '((make-verbose #t)
|
(add-flags '((force-unpacks #t)))]
|
||||||
(compiler-verbose #t)))]
|
[("-a" "--all-users") "Install archives to main (not user-specific) installation"
|
||||||
[("--trust-zos") "Trust existing .zos (use only with prepackaged .zos)"
|
(add-flags '((all-users #t)))]
|
||||||
(add-flags '((trust-existing-zos #t)))]
|
[("--mode") mode "Select a compilation mode"
|
||||||
[("-p" "--pause") "Pause at the end if there are any errors"
|
(add-flags `((compile-mode ,mode)))]
|
||||||
(add-flags '((pause-on-errors #t)))]
|
[("--doc-pdf") dir "Write doc PDF to <dir>"
|
||||||
[("--force") "Treat version mismatches for archives as mere warnings"
|
(add-flags `((doc-pdf-dest ,dir)))]
|
||||||
(add-flags '((force-unpacks #t)))]
|
[("-l") =>
|
||||||
[("-a" "--all-users") "Install archives to main (not user-specific) installation"
|
(lambda (flag . collections)
|
||||||
(add-flags '((all-users #t)))]
|
(map list collections))
|
||||||
[("--mode") mode "Select a compilation mode"
|
'("Setup specific <collection>s only" "collection")]
|
||||||
(add-flags `((compile-mode ,mode)))]
|
#:multi
|
||||||
[("--doc-pdf") dir "Write doc PDF to <dir>"
|
[("-P") owner package-name maj min
|
||||||
(add-flags `((doc-pdf-dest ,dir)))]
|
"Setup specified PLaneT packages only"
|
||||||
[("-l") =>
|
(set!
|
||||||
(lambda (flag . collections)
|
x-specific-planet-packages
|
||||||
(map list collections))
|
(cons (list owner package-name maj min) x-specific-planet-packages))]
|
||||||
'("Setup specific <collection>s only" "collection")])
|
#:handlers
|
||||||
(=>
|
(lambda (collections . archives)
|
||||||
(lambda (collections . archives)
|
(values (if (null? collections)
|
||||||
(values (if (null? collections)
|
null
|
||||||
null
|
(car collections))
|
||||||
(car collections))
|
archives))
|
||||||
archives))
|
'("archive")
|
||||||
'("archive")
|
(lambda (s)
|
||||||
(lambda (s)
|
(display s)
|
||||||
(display s)
|
(printf "If no <archive> or -l <collection> is specified, all collections are setup~n")
|
||||||
(printf "If no <archive> or -l <collection> is specified, all collections are setup~n")
|
(exit 0))))
|
||||||
(exit 0)))))
|
|
||||||
|
|
||||||
(values x-flags x-specific-collections x-specific-planet-packages x-archives)))
|
(values x-flags x-specific-collections x-specific-planet-packages x-archives)))
|
||||||
|
|
|
||||||
|
|
@ -621,6 +621,7 @@ static int run_from_cmd_line(int argc, char *_argv[],
|
||||||
/* No switches => -u mode */
|
/* No switches => -u mode */
|
||||||
script_mode = 1;
|
script_mode = 1;
|
||||||
no_more_switches = 1;
|
no_more_switches = 1;
|
||||||
|
sprog = argv[0];
|
||||||
evals_and_loads[num_enl] = argv[0];
|
evals_and_loads[num_enl] = argv[0];
|
||||||
eval_kind[num_enl++] = mzcmd_REQUIRE;
|
eval_kind[num_enl++] = mzcmd_REQUIRE;
|
||||||
argv++;
|
argv++;
|
||||||
|
|
@ -745,6 +746,8 @@ static int run_from_cmd_line(int argc, char *_argv[],
|
||||||
case 'r':
|
case 'r':
|
||||||
script_mode = 1;
|
script_mode = 1;
|
||||||
no_more_switches = 1;
|
no_more_switches = 1;
|
||||||
|
if (argc > 1)
|
||||||
|
sprog = argv[1];
|
||||||
case 'f':
|
case 'f':
|
||||||
if (argc < 2) {
|
if (argc < 2) {
|
||||||
PRINTF("%s: missing file name after %s switch\n",
|
PRINTF("%s: missing file name after %s switch\n",
|
||||||
|
|
@ -760,6 +763,8 @@ static int run_from_cmd_line(int argc, char *_argv[],
|
||||||
case 'u':
|
case 'u':
|
||||||
script_mode = 1;
|
script_mode = 1;
|
||||||
no_more_switches = 1;
|
no_more_switches = 1;
|
||||||
|
if (argc > 1)
|
||||||
|
sprog = argv[1];
|
||||||
case 't':
|
case 't':
|
||||||
if (argc < 2) {
|
if (argc < 2) {
|
||||||
PRINTF("%s: missing file name after %s switch\n",
|
PRINTF("%s: missing file name after %s switch\n",
|
||||||
|
|
@ -946,6 +951,7 @@ static int run_from_cmd_line(int argc, char *_argv[],
|
||||||
scheme_set_exec_cmd(prog);
|
scheme_set_exec_cmd(prog);
|
||||||
if (!sprog)
|
if (!sprog)
|
||||||
sprog = prog;
|
sprog = prog;
|
||||||
|
|
||||||
ps = scheme_set_run_cmd(sprog);
|
ps = scheme_set_run_cmd(sprog);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
@ -1040,8 +1046,8 @@ static int run_from_cmd_line(int argc, char *_argv[],
|
||||||
" -t <file>, --require <file> : Like -e '(require (file \"<file>\"))'\n"
|
" -t <file>, --require <file> : Like -e '(require (file \"<file>\"))'\n"
|
||||||
" -l <path>, --lib <path> : Like -e '(require (lib \"<path>\"))'\n"
|
" -l <path>, --lib <path> : Like -e '(require (lib \"<path>\"))'\n"
|
||||||
" -p <fl> <u> <pkg> : Like -e '(require (planet \"<fl>\" (\"<u>\" \"<pkg>\"))'\n"
|
" -p <fl> <u> <pkg> : Like -e '(require (planet \"<fl>\" (\"<u>\" \"<pkg>\"))'\n"
|
||||||
" -r, --script : Script mode; same as -f-\n"
|
" -r <file>, --script <file> : Same as -f <file> -N <file> --\n"
|
||||||
" -u, --require-script : Module script mode; same as -t-\n"
|
" -u <file>, --require-script <file> : Same as -t <file> -N <file> --\n"
|
||||||
" -k <n> <m> : Load executable-embedded code from file offset <n> to <m>\n"
|
" -k <n> <m> : Load executable-embedded code from file offset <n> to <m>\n"
|
||||||
" -m, --main : Call `main' with command-line arguments\n"
|
" -m, --main : Call `main' with command-line arguments\n"
|
||||||
" Interaction options:\n"
|
" Interaction options:\n"
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user