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

planet command now uses short-program+command-name properly.

Browse Source
This commit is contained in:
Robby Findler 2010-05-31 13:17:21 -05:00
parent e23db50e06
commit 733c9b9eec
2 changed files with 6 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/planet/private/cmdline-tool.rkt
View File

@ -31,7 +31,6 @@ PLANNED FEATURES:
(svn-style-command-line (svn-style-command-line
#:program (short-program+command-name) #:program (short-program+command-name)
#:argv (current-command-line-arguments) #:argv (current-command-line-arguments)
#:prefix (if raco? "raco " "")
"The Racket command-line tool for manipulating packages installed by PLaneT." "The Racket command-line tool for manipulating packages installed by PLaneT."
["create" "create a PLaneT archive from a directory" ["create" "create a PLaneT archive from a directory"
"\nCreate a PLaneT archive in the current directory whose contents are the directory <path>." "\nCreate a PLaneT archive in the current directory whose contents are the directory <path>."

14
collects/planet/private/command.rkt
View File

@ -35,19 +35,17 @@
(syntax-case stx () (syntax-case stx ()
[(_ #:program prog [(_ #:program prog
#:argv args #:argv args
#:prefix pfx-e
general-description general-description
[name description long-description body ... #:args formals final-expr] ...) [name description long-description body ... #:args formals final-expr] ...)
(with-syntax ([(n ...) (generate-temporaries #'(name ...))]) (with-syntax ([(n ...) (generate-temporaries #'(name ...))])
#'(let* ([pfx-x pfx-e] #'(let* ([p prog]
[p prog]
[a args] [a args]
[n name] ... [n name] ...
[argslist (cond [argslist (cond
[(list? a) a] [(list? a) a]
[(vector? a) (vector->list a)] [(vector? a) (vector->list a)]
[else (error 'command "expected a vector or list for arguments, received ~e" a)])] [else (error 'command "expected a vector or list for arguments, received ~e" a)])]
[help (λ () (display-help-message p pfx-x general-description `((name description) ...)))]) [help (λ () (display-help-message p general-description `((name description) ...)))])
(let-values ([(the-command remainder) (let-values ([(the-command remainder)
(if (null? argslist) (if (null? argslist)
(values "help" '()) (values "help" '())
@ -71,9 +69,9 @@
[else (help)]))))])) [else (help)]))))]))
;; display-help-message : string (listof (list string string)) -> void ;; display-help-message : string string (listof (list string string)) -> void
;; prints out the help message ;; prints out the help message
(define (display-help-message prog prefix general-description commands) (define (display-help-message prog general-description commands)
(let* ([maxlen (apply max (map (λ (p) (string-length (car p))) commands))] (let* ([maxlen (apply max (map (λ (p) (string-length (car p))) commands))]
[message-lines [message-lines
`(,(format "Usage: ~a <subcommand> [option ...] <arg ...>" prog) `(,(format "Usage: ~a <subcommand> [option ...] <arg ...>" prog)
@ -81,11 +79,11 @@
"" ""
,@(wrap-to-count general-description 80) ,@(wrap-to-count general-description 80)
"" ""
,(format "For help on a particular subcommand, type '~aplanet <subcommand> --help'" prefix) ,(format "For help on a particular subcommand, type '~a <subcommand> --help'" prog)
,@(map (λ (command) ,@(map (λ (command)
(let* ([padded-name (pad (car command) maxlen)] (let* ([padded-name (pad (car command) maxlen)]
[desc (cadr command)] [desc (cadr command)]
[msg (format " ~aplanet ~a ~a" prefix padded-name desc)]) [msg (format " ~a ~a ~a" prog padded-name desc)])
msg)) msg))
commands))]) commands))])
(for-each (λ (line) (display line) (newline)) message-lines))) (for-each (λ (line) (display line) (newline)) message-lines)))