853f959622
For example, complain if both `-u' and `-i' are specified, or if a bad `--deps' mode is provided.
134 lines
4.4 KiB
Racket
134 lines
4.4 KiB
Racket
#lang racket/base
|
|
(require racket/cmdline
|
|
planet/private/command
|
|
raco/command-name
|
|
racket/function
|
|
(for-syntax racket/base
|
|
racket/list
|
|
racket/syntax
|
|
syntax/parse))
|
|
|
|
(define ((string->option what valid-options) str)
|
|
(define s (string->symbol str))
|
|
(unless (memq s valid-options)
|
|
(raise-user-error (string->symbol
|
|
(format "~a ~a"
|
|
(short-program+command-name)
|
|
(current-svn-style-command)))
|
|
"invalid <~a>: ~a\n valid <~a>s are:~a"
|
|
what
|
|
str
|
|
what
|
|
(apply string-append
|
|
(for/list ([s (in-list valid-options)])
|
|
(format " ~a" s)))))
|
|
s)
|
|
|
|
(begin-for-syntax
|
|
(define symbol->keyword
|
|
(compose string->keyword symbol->string))
|
|
|
|
(define-syntax-class kind
|
|
#:attributes (default fun (arg-val 1))
|
|
[pattern #:bool
|
|
#:attr (arg-val 1) empty
|
|
#:attr default #'#f
|
|
#:attr fun #'(λ () #t)]
|
|
[pattern (#:sym name:id [opt:id ...] default:expr)
|
|
#:attr (arg-val 1) (list #'name)
|
|
#:attr fun #'(string->option 'name '(opt ...))]
|
|
[pattern (#:str name:id default:expr)
|
|
#:attr (arg-val 1) (list #'name)
|
|
#:attr fun #'identity])
|
|
|
|
(define-syntax-class option
|
|
#:attributes (command-line variable (param 1) (call 1))
|
|
[pattern (k:kind arg:id (alias:str ...) doc:expr)
|
|
#:do
|
|
[(define arg-kw (symbol->keyword (syntax->datum #'arg)))
|
|
(define arg-str (format "--~a" (syntax->datum #'arg)))
|
|
(define arg-var (generate-temporary #'arg))]
|
|
#:attr variable
|
|
(quasisyntax/loc #'arg
|
|
(define #,arg-var k.default))
|
|
#:attr (param 1)
|
|
(syntax-e
|
|
(quasisyntax/loc #'arg
|
|
[#,arg-kw [arg k.default]]))
|
|
#:attr (call 1)
|
|
(syntax-e
|
|
(quasisyntax/loc #'arg
|
|
[#,arg-kw #,arg-var]))
|
|
#:attr command-line
|
|
(quasisyntax/loc #'arg
|
|
[(alias ... #,arg-str)
|
|
k.arg-val ...
|
|
doc
|
|
(set! #,arg-var (k.fun k.arg-val ...))])])
|
|
|
|
(define-syntax-class group-kind
|
|
[pattern #:once-any]
|
|
[pattern #:once-each]
|
|
[pattern #:multi])
|
|
|
|
(define-splicing-syntax-class option-group
|
|
#:attributes ((command-line 1) variable (param 1) (call 1))
|
|
[pattern (~seq k:group-kind o:option ...)
|
|
#:attr (command-line 1)
|
|
(syntax->list #'(k o.command-line ...))
|
|
#:attr variable
|
|
#'(begin o.variable ...)
|
|
#:attr (param 1)
|
|
(syntax->list #'(o.param ... ...))
|
|
#:attr (call 1)
|
|
(syntax->list #'(o.call ... ...))])
|
|
|
|
(define-syntax-class command
|
|
#:attributes (name function variables command-line)
|
|
[pattern (name:id doc:expr og:option-group ... #:args args body:expr ...)
|
|
#:do
|
|
[(define name-str (symbol->string (syntax->datum #'name)))]
|
|
#:attr function
|
|
(syntax/loc #'name
|
|
(define (name og.param ... ... . args)
|
|
body ...))
|
|
#:attr variables
|
|
(syntax/loc #'name
|
|
(begin og.variable ...))
|
|
#:attr command-line
|
|
(quasisyntax/loc #'name
|
|
[#,name-str
|
|
doc doc
|
|
og.command-line ... ...
|
|
#:args args
|
|
(args-app args (name og.call ... ...))])]))
|
|
|
|
(define-syntax (args-app stx)
|
|
(syntax-parse stx
|
|
[(_ () (call ...))
|
|
(syntax/loc stx
|
|
(call ...))]
|
|
[(_ rest:id (call ...))
|
|
(syntax/loc stx
|
|
(apply call ... rest))]
|
|
[(_ (fst . snd) (call ...))
|
|
(syntax/loc stx
|
|
(args-app snd (call ... fst)))]))
|
|
|
|
(define-syntax (commands stx)
|
|
(syntax-parse stx
|
|
[(_ main-doc:expr c:command ...)
|
|
(syntax/loc stx
|
|
(begin
|
|
c.function ...
|
|
(provide c.name ...)
|
|
(module+ main
|
|
c.variables ...
|
|
(svn-style-command-line
|
|
#:program (short-program+command-name)
|
|
#:argv (current-command-line-arguments)
|
|
main-doc
|
|
c.command-line ...))))]))
|
|
|
|
(provide commands)
|