146 lines
8.1 KiB
Racket
146 lines
8.1 KiB
Racket
#lang mzscheme
|
|
|
|
(require (only racket/cmdline parse-command-line))
|
|
|
|
(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-object
|
|
(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))
|
|
(syntax-case stx ()
|
|
[(_ program-name argv clause ...)
|
|
(let ([clauses
|
|
(let loop ([csrcs (syntax->list #'(clause ...))][clauses null])
|
|
(with-syntax ([(clause ...) clauses])
|
|
(if (null? csrcs)
|
|
#'((list clause ...) (lambda (accum) (void)) null)
|
|
(let ([line (car csrcs)]
|
|
[arest (cdr csrcs)])
|
|
(syntax-case* line (help-labels => args) id=?
|
|
[(help-labels s ...)
|
|
(begin
|
|
(unless (andmap (lambda (x) (string? (syntax-e x)))
|
|
(syntax->list #'(s ...)))
|
|
(serror "help-labels clause must contain only strings" line))
|
|
(loop arest #'(clause ... '(help-labels s ...))))]
|
|
[(tag . rest)
|
|
(ormap (lambda (x) (id=? #'tag x))
|
|
(syntax->list #'(once-each once-any multi final)))
|
|
(with-syntax
|
|
([sublines
|
|
(let slloop ([sublines (syntax->list #'rest)])
|
|
(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)
|
|
(extract-list
|
|
rest (lambda (x) (string? (syntax-e x))))]
|
|
[(expr1 rest)
|
|
(extract-one
|
|
"handler body expressions" rest line)])
|
|
(when (null? helps)
|
|
(serror "missing help string/s"))
|
|
(with-syntax ([formals formals]
|
|
[formal-names (formal-names formals)]
|
|
[helps helps]
|
|
[expr1 expr1]
|
|
[rest rest])
|
|
#'(list 'flags
|
|
(lambda (flag . formals) expr1 . rest)
|
|
'(helps . formal-names))))]))])
|
|
#'(subline . looped))))])
|
|
(loop arest #'(clause ... (list 'tag . sublines))))]
|
|
[(=> finish-proc arg-help help-proc unknown-proc)
|
|
(begin
|
|
(unless (null? arest)
|
|
(serror "=> must be the last clause line"))
|
|
#'((list clause ...)
|
|
finish-proc arg-help help-proc unknown-proc))]
|
|
[(=> finish-proc arg-help help-proc)
|
|
(begin
|
|
(unless (null? arest)
|
|
(serror "=> must be the last clause line"))
|
|
#'((list clause ...)
|
|
finish-proc arg-help help-proc))]
|
|
[(=> finish-proc arg-help)
|
|
(begin
|
|
(unless (null? arest)
|
|
(serror "=> must be the last clause line"))
|
|
#'((list clause ...) finish-proc arg-help))]
|
|
[(=> . _)
|
|
(serror "bad => line" line)]
|
|
[(args arg-formals body1 body ...)
|
|
(begin
|
|
(unless (null? arest)
|
|
(serror "args must be the last clause" line))
|
|
(let ([formals
|
|
(let loop ([f #'arg-formals])
|
|
(syntax-case f ()
|
|
[() null]
|
|
[(arg . rest)
|
|
(identifier? #'arg)
|
|
(cons #'arg (loop #'rest))]
|
|
[arg
|
|
(identifier? #'arg)
|
|
(list #'arg)]
|
|
[else
|
|
(serror "bad argument list" line)]))])
|
|
(with-syntax ([formal-names (formal-names formals)])
|
|
#'((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])
|
|
#'(parse-command-line program-name argv . clauses)))]))
|