diff --git a/collects/planet/planet.ss b/collects/planet/planet.ss index 4dc1bbdd96..0045933a65 100644 --- a/collects/planet/planet.ss +++ b/collects/planet/planet.ss @@ -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 .") + "\nCreate a PLaneT archive in the current directory whose contents are the directory ." #: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\" ( )))" - "would install") + " +Download and install the package that + (require (planet \"file.ss\" ( ))) +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 into the planet cache as though it had been downloaded from the planet server. The installed package has path" - " (planet ( ))") + " +Install local file into the planet cache as though it had been downloaded from the planet server. The installed package has path + (planet ( ))" #: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))]))))) + + + + + ;; ============================================================ diff --git a/collects/planet/private/command.ss b/collects/planet/private/command.ss index 26d417147b..38da135cfd 100644 --- a/collects/planet/private/command.ss +++ b/collects/planet/private/command.ss @@ -15,7 +15,7 @@ #:program #:argv - [ + [ ... 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 [option ...] \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 --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 [option ...] " 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 --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)])) \ No newline at end of file + [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))]))])) \ No newline at end of file diff --git a/collects/planet/private/prefix-dispatcher.ss b/collects/planet/private/prefix-dispatcher.ss index 023454f9eb..bf5283aa0e 100644 --- a/collects/planet/private/prefix-dispatcher.ss +++ b/collects/planet/private/prefix-dispatcher.ss @@ -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)))))]))