80-column output
svn: r9309
This commit is contained in:
Jacob Matthews
parent
f79464179d
commit
c1167e3b18
|
|
@ -3,11 +3,8 @@
|
|||
This module contains code that implements the `planet' command-line tool.
|
||||
|
||||
PLANNED FEATURES:
|
||||
|
||||
2. Remove a package from the cache
|
||||
3. Disable a package without removing it (disabling meaning
|
||||
that if it's a tool it won't start w/ DrScheme, etc)
|
||||
4. Examine and alter linkage table
|
||||
* Disable a package without removing it (disabling meaning
|
||||
that if it's a tool it won't start w/ DrScheme, etc)
|
||||
|#
|
||||
(require mzlib/string
|
||||
mzlib/file
|
||||
|
|
@ -34,63 +31,70 @@ PLANNED FEATURES:
|
|||
#:argv (current-command-line-arguments)
|
||||
"PLT Scheme PLaneT command-line tool. Provides commands to help you manipulate your local planet cache."
|
||||
["create" "create a PLaneT archive from a directory"
|
||||
'("" "Create 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>."
|
||||
#:once-each
|
||||
[("-f" "--force") "force a package to be created even its info.ss file contains errors."
|
||||
[("-f" "--force") ("force a package to be created even if its info.ss file contains"
|
||||
"errors.")
|
||||
(force-package-building? #t)]
|
||||
#:args (path)
|
||||
(do-archive path)]
|
||||
["install" "download and install a given package"
|
||||
'("" "Download and install the package that"
|
||||
" (require (planet \"file.ss\" (<owner> <pkg> <maj> <min>)))"
|
||||
"would install")
|
||||
"
|
||||
Download and install the package that
|
||||
(require (planet \"file.ss\" (<owner> <pkg> <maj> <min>)))
|
||||
would install"
|
||||
#:args (owner pkg maj min)
|
||||
(download/install owner pkg maj min)]
|
||||
["remove" "remove the specified package from the local cache"
|
||||
'("" "Remove the specified package from the local cache, optionally also removing its distribution file")
|
||||
"
|
||||
Remove the specified package from the local cache, optionally also removing its distribution file"
|
||||
#:once-each
|
||||
[("-e" "--erase") "also remove the package's distribution file from the uninstalled-package cache"
|
||||
[("-e" "--erase")
|
||||
("also remove the package's distribution file from the"
|
||||
"uninstalled-package cache")
|
||||
(erase? #t)]
|
||||
#:args (owner pkg maj min)
|
||||
((if (erase?) erase remove) owner pkg maj min)]
|
||||
["show" "list the packages installed in the local cache"
|
||||
'("" "List the packages installed in the local cache")
|
||||
"\nList the packages installed in the local cache"
|
||||
#:once-any
|
||||
[("-p" "--packages") "show packages only (default)" (displayer show-installed-packages)]
|
||||
[("-l" "--linkage") "show linkage table only" (displayer show-linkage)]
|
||||
[("-a" "--all") "show packages and linkage" (displayer (λ () (show-installed-packages) (newline) (show-linkage)))]
|
||||
#:args ()
|
||||
((displayer))]
|
||||
["clearlinks" "clear the linkage table, unlinking all packages and allowing upgrades"
|
||||
'("" "Clear the linkage table, unlinking all packages and allowing upgrades")
|
||||
["clearlinks" "clear the linkage table, allowing upgrades"
|
||||
"\nClear the linkage table, allowing upgrades"
|
||||
#:args ()
|
||||
(unlink-all)]
|
||||
["fileinject" "install a local file to the planet cache"
|
||||
'("" "Install local file <plt-file> into the planet cache as though it had been downloaded from the planet server. The installed package has path"
|
||||
" (planet (<owner> <plt-file's filename> <maj> <min>))")
|
||||
"
|
||||
Install local file <plt-file> into the planet cache as though it had been downloaded from the planet server. The installed package has path
|
||||
(planet (<owner> <plt-file's filename> <maj> <min>))"
|
||||
#:args (owner plt-file maj min)
|
||||
(install-plt-file plt-file owner maj min)]
|
||||
["link" "create a development link"
|
||||
'("" "Create a development link between the specified package specifier and the specified directory name")
|
||||
"\nCreate a development link between the specified package specifier and the specified directory name"
|
||||
#:args (owner pkg maj min path)
|
||||
(add-hard-link-cmd owner pkg maj min path)]
|
||||
["unlink" "remove development link associated with the given package"
|
||||
'("" "Remove development link associated with the given package")
|
||||
"\nRemove development link associated with the given package"
|
||||
#:args (owner pkg maj min)
|
||||
(remove-hard-link-cmd owner pkg maj min)]
|
||||
["fetch" "download a package file without installing it"
|
||||
'("" "Download the given package file without installing it")
|
||||
"\nDownload the given package file without installing it"
|
||||
#:args (owner pkg maj min)
|
||||
(download/no-install owner pkg maj min)]
|
||||
["url" "get a URL for the given package"
|
||||
'("" "Get a URL for the given package."
|
||||
"This is not necessary for normal use of planet, but may be helpful in some circumstances for retrieving packages.")
|
||||
"
|
||||
Get a URL for the given package.
|
||||
This is not necessary for normal use of planet, but may be helpful in some circumstances for retrieving packages."
|
||||
#:args (owner pkg maj min)
|
||||
(get-download-url owner pkg maj min)]
|
||||
["open" "unpack the contents of the given package"
|
||||
'("" "Unpack the contents of the given package into the given directory without installing."
|
||||
"This command is not necessary for normal use of planet. It is intended to allow you to inspect package contents"
|
||||
"offline without needing to install the package.")
|
||||
"
|
||||
Unpack the contents of the given package into the given directory without installing.
|
||||
This command is not necessary for normal use of planet. It is intended to allow you to inspect package contents offline without needing to install the package."
|
||||
#:args (plt-file target)
|
||||
(do-unpack plt-file target)]
|
||||
|
||||
|
|
@ -254,6 +258,11 @@ PLANNED FEATURES:
|
|||
[((caar c) (car a) (car b)) #t]
|
||||
[(not ((cadar c) (car a) (car b))) #f]
|
||||
[else (loop (cdr a) (cdr b) (cdr c))])))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;; ============================================================
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@
|
|||
#:program <name-of-the-program-string>
|
||||
#:argv <argument vector, generally (current-command-line-arguments)>
|
||||
<program-general-description string>
|
||||
[<command1> <brief-help-string> <long-help-description-listof-strings>
|
||||
[<command1> <brief-help-string> <long-help-description-string>
|
||||
... arguments just like the command-line macro takes, until ...
|
||||
#:args formals
|
||||
body-expr] ...)
|
||||
|
|
@ -45,7 +45,7 @@
|
|||
[(list? a) a]
|
||||
[(vector? a) (vector->list a)]
|
||||
[else (error 'command "expected a vector or list for arguments, received ~e" a)])]
|
||||
[help (λ () (display-help-message p general-description '((name description) ...)))])
|
||||
[help (λ () (display-help-message p general-description `((name description) ...)))])
|
||||
(let-values ([(the-command remainder)
|
||||
(if (null? argslist)
|
||||
(values "help" '())
|
||||
|
|
@ -60,7 +60,7 @@
|
|||
(λ (_ . formals) final-expr)
|
||||
(pimap symbol->string 'formals)
|
||||
(λ (help-string)
|
||||
(for-each (λ (l) (display l) (newline)) long-description)
|
||||
(for-each (λ (l) (display l) (newline)) (wrap-to-count long-description 80))
|
||||
(newline)
|
||||
(display "Usage:\n")
|
||||
(display help-string)
|
||||
|
|
@ -72,21 +72,22 @@
|
|||
;; display-help-message : string (listof (list string string)) -> void
|
||||
;; prints out the help message
|
||||
(define (display-help-message prog general-description commands)
|
||||
(let ([maxlen (apply max (map (λ (p) (string-length (car p))) commands))])
|
||||
(begin
|
||||
(printf "Usage: ~a <subcommand> [option ...] <arg ...>\n" prog)
|
||||
(printf "[note: you can name a subcommand by typing any unambiguous prefix of it.]\n\n")
|
||||
(display general-description)
|
||||
(newline)
|
||||
(newline)
|
||||
(display "For help on a particular subcommand, type 'planet <subcommand> --help'\n")
|
||||
(display "Available subcommands:\n")
|
||||
(for-each (λ (command)
|
||||
(let ([padded-name (pad (car command) maxlen)]
|
||||
[desc (cadr command)])
|
||||
(printf " ~a ~a\n" padded-name desc)))
|
||||
commands))))
|
||||
|
||||
(let* ([maxlen (apply max (map (λ (p) (string-length (car p))) commands))]
|
||||
[message-lines
|
||||
`(,(format "Usage: ~a <subcommand> [option ...] <arg ...>" prog)
|
||||
"[note: you can name a subcommand by typing any unambiguous prefix of it.]"
|
||||
""
|
||||
,@(wrap-to-count general-description 80)
|
||||
""
|
||||
"For help on a particular subcommand, type 'planet <subcommand> --help'"
|
||||
"Available subcommands:"
|
||||
,@(map (λ (command)
|
||||
(let* ([padded-name (pad (car command) maxlen)]
|
||||
[desc (cadr command)]
|
||||
[msg (format " ~a ~a" padded-name desc)])
|
||||
msg))
|
||||
commands))])
|
||||
(for-each (λ (line) (display line) (newline)) message-lines)))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; utility
|
||||
|
|
@ -104,4 +105,25 @@
|
|||
[(null? pil) '()]
|
||||
[(pair? pil) (cons (pimap f (car pil))
|
||||
(pimap f (cdr pil)))]
|
||||
[else (f pil)]))
|
||||
[else (f pil)]))
|
||||
|
||||
;; wrap-to-count : string nat -> (listof string)
|
||||
;; breaks str into substrings such that no substring
|
||||
;; is longer than n characters long. Only breaks on spaces, which
|
||||
;; are eaten in the process.
|
||||
(define (wrap-to-count str n)
|
||||
(cond
|
||||
[(< (string-length str) n) (list str)]
|
||||
[(regexp-match-positions #rx"\n" str 0 n)
|
||||
=>
|
||||
(λ (posn)
|
||||
(let-values ([(x y) (values (car (car posn)) (cdr (car posn)))])
|
||||
(cons (substring str 0 x) (wrap-to-count (substring str y) n))))]
|
||||
[else
|
||||
;; iterate backwards from char n looking for a good break
|
||||
(let loop ([k n])
|
||||
(cond
|
||||
[(= k 0) (error wrap-to-count "could not break string")]
|
||||
[(char=? (string-ref str k) #\space)
|
||||
(cons (substring str 0 k) (wrap-to-count (substring str (add1 k)) n))]
|
||||
[else (loop (sub1 k))]))]))
|
||||
|
|
@ -74,15 +74,54 @@
|
|||
|
||||
|
||||
(define-syntax (prefix-case stx)
|
||||
(syntax-case stx (else)
|
||||
|
||||
(define (else? stx)
|
||||
(syntax-case stx (else)
|
||||
[(else clause) #t]
|
||||
[_ #f]))
|
||||
|
||||
(define (amb? stx)
|
||||
(syntax-case stx (ambiguous)
|
||||
[(ambiguous (name) body) #t]
|
||||
[_ #f]))
|
||||
|
||||
(define (extract-clause name options transformer default)
|
||||
(case (length options)
|
||||
[(0) default]
|
||||
[(1) (transformer (car options))]
|
||||
[else
|
||||
(raise-syntax-error #f (format "only 1 ~a clause is allowed" name) stx (list-ref options 1))]))
|
||||
|
||||
(define (else-clause->body c)
|
||||
(syntax-case c (else)
|
||||
[(else body) #'body]
|
||||
[_ (raise-syntax-error #f "malformed else clause" stx c)]))
|
||||
|
||||
(define (amb-clause->body c)
|
||||
(syntax-case c (ambiguous)
|
||||
[(ambiguous (name) body) #'(λ (name) body)]
|
||||
[_ (raise-syntax-error #f "malformed ambiguous clause" stx c)]))
|
||||
|
||||
(syntax-case stx ()
|
||||
[(_ elt
|
||||
[option result] ...
|
||||
[else alternative])
|
||||
#'(with-handlers ([exn:prefix-dispatcher? (λ (e) alternative)])
|
||||
(((get-prefix-dispatcher (list (list option (λ () result)) ...))
|
||||
elt)))]
|
||||
[(_ elt [option result] ...)
|
||||
#'(let ([e elt]) (prefix-case e [option result] ... [else (error 'prefix-case "element ~e was not a prefix" e)]))]))
|
||||
clause ...)
|
||||
(let* ([clauses (syntax-e #'(clause ...))]
|
||||
[else-clauses (filter else? clauses)]
|
||||
[amb-clauses (filter amb? clauses)]
|
||||
[rest (filter (λ (x) (not (or (else? x) (amb? x)))) clauses)]
|
||||
[else (extract-clause "else" else-clauses else-clause->body
|
||||
#'(error 'prefix-case "element ~e was not a prefix" e))]
|
||||
[amb (extract-clause "ambiguous" amb-clauses amb-clause->body
|
||||
#'(λ (opts) (error 'prefix-case "element matches more than one option: ~s" opts)))])
|
||||
(with-syntax ([else-clause else]
|
||||
[amb-clause amb]
|
||||
[((option result) ...) rest])
|
||||
#'(with-handlers ([exn:ambiguous-command?
|
||||
(λ (e) (amb-clause (exn:ambiguous-command-possibilities e)))]
|
||||
[exn:unknown-command?
|
||||
(λ (e) else-clause)])
|
||||
(((get-prefix-dispatcher (list (list option (λ () result)) ...))
|
||||
elt)))))]))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user