From 3a09e8fa0ab0fb5c2c70c0b81073b783f07eb9df Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 20 Nov 2013 14:48:59 -0700 Subject: [PATCH] raco pkg config: show all by default Also, better help, checking, and error reporting on arguments. Related to PR 14180 Merge to v6.0 (cherry picked from commit 53ce3b7b96e627989d3d4a506329cd5b51bce8d4) --- .../racket-doc/pkg/scribblings/lib.scrbl | 6 +- .../racket-doc/pkg/scribblings/pkg.scrbl | 14 ++- racket/collects/pkg/commands.rkt | 36 +++++-- racket/collects/pkg/lib.rkt | 101 +++++++++++++----- racket/collects/pkg/main.rkt | 35 +++--- racket/collects/planet/private/command.rkt | 78 ++++++++------ 6 files changed, 187 insertions(+), 83 deletions(-) diff --git a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/lib.scrbl b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/lib.scrbl index a280f5caa5..bfd27b2c8f 100644 --- a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/lib.scrbl +++ b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/lib.scrbl @@ -157,11 +157,15 @@ directory should be removed after the package content is no longer needed, and a list of module paths provided by the package.} -@defproc[(pkg-config [set? boolean?] [keys/vals list?]) +@defproc[(pkg-config [set? boolean?] [keys/vals list?] + [#:from-command-line? from-command-line? boolean? #f]) void?]{ Implements @racket[pkg-config-command]. +If @racket[from-command-line?] is true, error messages may suggest +specific command-line flags for @command-ref{config}. + The package lock must be held (allowing writes if @racket[set?] is true); see @racket[with-pkg-lock].} diff --git a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/pkg.scrbl b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/pkg.scrbl index 3bcf6df21f..b67eb8f1a7 100644 --- a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/pkg.scrbl +++ b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/pkg.scrbl @@ -599,8 +599,14 @@ the given @nonterm{pkg}s. ] } -@subcommand{@command/toc{config} @nonterm{option} ... @nonterm{key} @nonterm{val} ... --- -View and modify configuration of the package manager itself, with the following @nonterm{option}s: +@subcommand{@command/toc{config} @nonterm{option} ... @optional[@nonterm{key}] @nonterm{val} ... --- +View and modify the configuration of the package manager. If @nonterm{key} is not provided, +the values for all recognized keys are shown. The @nonterm{val} arguments are allowed +only when @DFlag{set} is used, in which case the @nonterm{val}s are used as the new values +for @nonterm{key}. + + The @exec{config} sub-command accepts + with the following @nonterm{option}s: @itemlist[ @item{@DFlag{set} --- Sets an option, rather than printing it.} @@ -614,6 +620,8 @@ View and modify configuration of the package manager itself, with the following The valid @nonterm{key}s are: @itemlist[ + @item{@exec{name} --- A string for the installation's name, which is used by @exec{user} + @tech{package scope} and defaults to the Racket version.} @item{@exec{catalogs} --- A list of URLs for @tech{package catalogs}.} @item{@exec{default-scope} --- Either @exec{installation} or @exec{user}. The value of this key at @exec{user} scope (possibly defaulting from @@ -621,8 +629,6 @@ View and modify configuration of the package manager itself, with the following the default @tech{package scope} for @exec{raco pkg} commands for which a scope is not inferred from a given set of package names (even for @command{config}, which is consistent but potentially confusing).} - @item{@exec{name} --- A string for the installation's name, which is used by @exec{user} - @tech{package scope} and defaults to the Racket version.} @item{@exec{download-cache-dir} --- A directory that holds copies of downloaded packages, used to avoid re-downloading if the same URL and checksum combination is requested again. The default cache directory is diff --git a/racket/collects/pkg/commands.rkt b/racket/collects/pkg/commands.rkt index f3978a820d..d4c137fe06 100644 --- a/racket/collects/pkg/commands.rkt +++ b/racket/collects/pkg/commands.rkt @@ -6,7 +6,8 @@ (for-syntax racket/base racket/list racket/syntax - syntax/parse)) + syntax/parse + syntax/stx)) (define ((string->option what valid-options) str) (define s (string->symbol str)) @@ -104,15 +105,36 @@ #:attr (command-line 1) (syntax->list #'(#:usage-help s ...))]) + (define-splicing-syntax-class arguments + #:attributes (accum args (body 1) help-strs) + [pattern (~seq #:args args + body:expr ...) + #:with accum #'ignored + #:with help-strs (with-syntax ([strs + (map symbol->string + (map syntax->datum + (let loop ([args #'args]) + (cond + [(stx-null? args) null] + [(stx-pair? args) + (cons (stx-car args) + (loop (stx-cdr args)))] + [else + (list args)]))))]) + #`(list . strs))] + [pattern (~seq #:handlers + (lambda (accum . args) body:expr ...) + help-strs:expr)]) + (define-syntax-class command #:attributes (name function variables command-line) - [pattern (name:id doc:expr uh:usage-help ... og:option-group ... #:args args body:expr ...) + [pattern (name:id doc:expr uh:usage-help ... og:option-group ... arg:arguments) #:do [(define name-str (symbol->string (syntax->datum #'name)))] #:attr function (syntax/loc #'name - (define (name og.param ... ... . args) - body ...)) + (define (name og.param ... ... . arg.args) + arg.body ...)) #:attr variables (syntax/loc #'name (begin og.variable ...)) @@ -122,8 +144,10 @@ doc doc uh.command-line ... ... og.command-line ... ... - #:args args - (args-app args (name og.call ... ...))])])) + #:handlers + (lambda (accum . arg.args) + (args-app arg.args (name og.call ... ...))) + arg.help-strs])])) (define-syntax (args-app stx) (syntax-parse stx diff --git a/racket/collects/pkg/lib.rkt b/racket/collects/pkg/lib.rkt index 854daf2d34..664e12a9fd 100644 --- a/racket/collects/pkg/lib.rkt +++ b/racket/collects/pkg/lib.rkt @@ -2360,10 +2360,35 @@ (unless quiet? (printf "Packages migrated\n"))))) -(define (pkg-config config:set key+vals) +(define (pkg-config config:set key+vals + #:from-command-line? [from-command-line? #f]) (cond [config:set (match key+vals + [(list) + (pkg-error "no config key given")] + [(list (and key + (or "default-scope" + "name" + "download-cache-max-files" + "download-cache-max-bytes" + "download-cache-dir"))) + (pkg-error (~a "missing value for config key\n" + " config key: ~a") + key)] + [(list* (and key + (or "default-scope" + "name" + "download-cache-max-files" + "download-cache-max-bytes" + "download-cache-dir")) + val + more-vals) + (pkg-error (~a "too many values provided for config key\n" + " config key: ~a\n" + " given values:~a") + key + (format-list (cons val more-vals)))] [(list* (and key "catalogs") val) (update-pkg-cfg! 'catalogs val)] [(list (and key "default-scope") val) @@ -2381,6 +2406,16 @@ " current package scope: ~a") (current-pkg-scope))) (update-pkg-cfg! 'installation-name val)] + [(list (and key "download-cache-dir") + val) + (unless (complete-path? val) + (pkg-error (~a "invalid value for config key\n" + " not an absolute path\n" + " config key: ~a\n" + " given value: ~a") + key + val)) + (update-pkg-cfg! (string->symbol key) val)] [(list (and key (or "download-cache-max-files" "download-cache-max-bytes")) val) @@ -2391,32 +2426,45 @@ " valid values: real numbers") key val)) - (update-pkg-cfg! (string->symbol key) val)] - [(list key) - (pkg-error "unsupported config key\n key: ~e" key)] - [(list) - (pkg-error "config key not provided")])] + (update-pkg-cfg! (string->symbol key) (string->number val))] + [(list* key args) + (pkg-error "unsupported config key\n key: ~a" key)])] [else + (define (show key+vals indent) + (match key+vals + [(list key) + (match key + ["catalogs" + (for ([s (in-list (read-pkg-cfg/def 'catalogs))]) + (printf "~a~a\n" indent s))] + ["default-scope" + (printf "~a~a\n" indent (read-pkg-cfg/def 'default-scope))] + ["name" + (printf "~a~a\n" indent (read-pkg-cfg/def 'installation-name))] + [(or "download-cache-dir" + "download-cache-max-files" + "download-cache-max-bytes") + (printf "~a~a\n" indent (read-pkg-cfg/def (string->symbol key)))] + [_ + (pkg-error "unsupported config key\n key: ~e" key)])] + [(list) + (pkg-error "config key not provided")] + [_ + (pkg-error (~a "multiple config keys provided" + (if from-command-line? + ";\n supply `--set' to set a config key's value" + "")))])) (match key+vals - [(list key) - (match key - ["catalogs" - (for ([s (in-list (read-pkg-cfg/def 'catalogs))]) - (printf "~a\n" s))] - ["default-scope" - (printf "~a\n" (read-pkg-cfg/def 'default-scope))] - ["name" - (printf "~a\n" (read-pkg-cfg/def 'installation-name))] - [(or "download-cache-dir" - "download-cache-max-files" - "download-cache-max-bytes") - (printf "~a\n" (read-pkg-cfg/def (string->symbol key)))] - [_ - (pkg-error "unsupported config key\n key: ~e" key)])] [(list) - (pkg-error "config key not provided")] - [_ - (pkg-error "multiple config keys provided (not in value-setting mode)")])])) + (for ([key (in-list '("name" + "catalogs" + "default-scope" + "download-cache-dir" + "download-cache-max-files" + "download-cache-max-bytes"))]) + (printf "~a:\n" key) + (show (list key) " "))] + [_ (show key+vals "")])])) (define (create-as-is create:format pkg-name dir orig-dir #:quiet? [quiet? #f] @@ -3057,8 +3105,9 @@ boolean? pkg-desc?)] [pkg-config - (-> boolean? list? - void?)] + (->* (boolean? (listof string?)) + (#:from-command-line? boolean?) + void?)] [pkg-create (->* ((or/c 'zip 'tgz 'plt 'MANIFEST) path-string?) diff --git a/racket/collects/pkg/main.rkt b/racket/collects/pkg/main.rkt index 19416b63f2..0a3fb76894 100644 --- a/racket/collects/pkg/main.rkt +++ b/racket/collects/pkg/main.rkt @@ -138,8 +138,8 @@ ;; ---------------------------------------- [install "Install packages" - #:usage-help "Installs the packages specified by ..." - "If no sources are specified, installs the current directory." + #:usage-help "Installs the packages specified by ..., and" + "if no sources are specified, installs the current directory" #:once-each install-type-flags ... #:once-any @@ -385,20 +385,27 @@ ;; ---------------------------------------- [config "View and modify the package manager's configuration" - #:once-each - [#:bool set () "Set to ..."] + #:usage-help "Shows value for , shows values for all s if" + " none is given, or sets a single " + " if --set is specified" + #:once-any + [#:bool set () "Set to s"] #:once-any scope-flags ... - #:args (key . val) - (call-with-package-scope - 'config - scope scope-dir installation user #f #f - (lambda () - (if set - (with-pkg-lock - (pkg-config #t (cons key val))) - (with-pkg-lock/read-only - (pkg-config #f (cons key val))))))] + #:handlers + (lambda (accum . key+vals) + (call-with-package-scope + 'config + scope scope-dir installation user #f #f + (lambda () + (if set + (with-pkg-lock + (pkg-config #t key+vals + #:from-command-line? #t)) + (with-pkg-lock/read-only + (pkg-config #f key+vals + #:from-command-line? #t)))))) + (list "key" "val")] ;; ---------------------------------------- [catalog-show "Show package information as reported by a catalog" diff --git a/racket/collects/planet/private/command.rkt b/racket/collects/planet/private/command.rkt index 8ec19b97f4..cd5481406b 100644 --- a/racket/collects/planet/private/command.rkt +++ b/racket/collects/planet/private/command.rkt @@ -39,38 +39,52 @@ [(_ #:program prog #:argv args general-description - [name description long-description body ... #:args formals final-expr] ...) - (with-syntax ([(n ...) (generate-temporaries #'(name ...))]) - #'(let* ([p prog] - [a args] - [n name] ... - [argslist (cond - [(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) ...)))]) - (let-values ([(the-command remainder) - (if (null? argslist) - (values "help" '()) - (values (car argslist) (cdr argslist)))]) - (prefix-case the-command - [n - (parameterize ([current-svn-style-command n]) - (command-line - #:program (format "~a ~a" p n) - #:argv remainder - body ... - #:handlers - (λ (_ . formals) final-expr) - (pimap symbol->string 'formals) - (λ (help-string) - (for-each (λ (l) (display l) (newline)) (wrap-to-count long-description 80)) - (newline) - (display "Usage:\n") - (display help-string) - (exit))))] ... - ["help" (help)] - [else (help)]))))])) + clause ...) + (with-syntax ([(((name description long-description body ...) + accum formals arg-help-strs final-expr) + ...) + (map (lambda (clause) + (syntax-case clause () + [[name description long-description body ... + #:args formals final-expr] + #'((name description long-description body ...) + ignored formals (pimap symbol->string 'formals) final-expr)] + [(name description long-description body ... + #:handlers (lambda (accum . formals) final-expr) arg-help-strs) + #'((name description long-description body ...) + accum formals arg-help-strs final-expr)])) + (syntax->list #'(clause ...)))]) + (with-syntax ([(n ...) (generate-temporaries #'(name ...))]) + #'(let* ([p prog] + [a args] + [n name] ... + [argslist (cond + [(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) ...)))]) + (let-values ([(the-command remainder) + (if (null? argslist) + (values "help" '()) + (values (car argslist) (cdr argslist)))]) + (prefix-case the-command + [n + (parameterize ([current-svn-style-command n]) + (command-line + #:program (format "~a ~a" p n) + #:argv remainder + body ... + #:handlers + (λ (accum . formals) final-expr) + arg-help-strs + (λ (help-string) + (for-each (λ (l) (display l) (newline)) (wrap-to-count long-description 80)) + (newline) + (display "Usage:\n") + (display help-string) + (exit))))] ... + ["help" (help)] + [else (help)])))))])) ;; display-help-message : string string (listof (list string string)) -> void