From 853f959622022328785769fc4a9e9743a05ba113 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 21 Dec 2012 17:29:23 -0700 Subject: [PATCH] raco pkg: improve command-line checking and error reporting For example, complain if both `-u' and `-i' are specified, or if a bad `--deps' mode is provided. --- collects/planet/private/command.rkt | 32 +++++----- collects/planet2/commands.rkt | 54 +++++++++++++---- collects/planet2/lib.rkt | 10 ++-- collects/planet2/main.rkt | 68 ++++++++++++++-------- collects/planet2/scribblings/planet2.scrbl | 15 +++-- 5 files changed, 118 insertions(+), 61 deletions(-) diff --git a/collects/planet/private/command.rkt b/collects/planet/private/command.rkt index 75661741f7..25934602bf 100644 --- a/collects/planet/private/command.rkt +++ b/collects/planet/private/command.rkt @@ -3,7 +3,8 @@ racket/cmdline (for-syntax racket/base)) -(provide svn-style-command-line) +(provide svn-style-command-line + current-svn-style-command) ;; implements an "svn-style" command-line interface as a wrapper around racket/cmdline. At the moment, ;; it is light on error-checking and makes choices that are somewhat specific to the PLaneT commandline @@ -31,6 +32,8 @@ ;; This means that no command name may be a prefix of any other command name, because it ;; would mean there was no way to unambiguously name the shorter one. +(define current-svn-style-command (make-parameter #f)) + (define-syntax (svn-style-command-line stx) (syntax-case stx () [(_ #:program prog @@ -52,19 +55,20 @@ (values (car argslist) (cdr argslist)))]) (prefix-case the-command [n - (command-line - #:program (format "~a ~a" p n) - #:argv remainder - body ... - #:handlers - (λ (_ . formals) final-expr) - (ensure-list (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)))] ... + (parameterize ([current-svn-style-command n]) + (command-line + #:program (format "~a ~a" p n) + #:argv remainder + body ... + #:handlers + (λ (_ . formals) final-expr) + (ensure-list (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)]))))])) diff --git a/collects/planet2/commands.rkt b/collects/planet2/commands.rkt index aa48acb331..7e1d67703b 100644 --- a/collects/planet2/commands.rkt +++ b/collects/planet2/commands.rkt @@ -8,6 +8,22 @@ 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)) @@ -18,11 +34,11 @@ #:attr (arg-val 1) empty #:attr default #'#f #:attr fun #'(λ () #t)] - [pattern (#:sym default:expr) - #:attr (arg-val 1) (list #'string) - #:attr fun #'string->symbol] - [pattern (#:str default:expr) - #:attr (arg-val 1) (list #'string) + [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 @@ -50,26 +66,42 @@ 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 o:option ... #:args args body:expr ...) + [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 o.param ... ... . args) + (define (name og.param ... ... . args) body ...)) #:attr variables (syntax/loc #'name - (begin o.variable ...)) + (begin og.variable ...)) #:attr command-line (quasisyntax/loc #'name [#,name-str doc doc - #:once-each - o.command-line ... + og.command-line ... ... #:args args - (args-app args (name o.call ... ...))])])) + (args-app args (name og.call ... ...))])])) (define-syntax (args-app stx) (syntax-parse stx diff --git a/collects/planet2/lib.rkt b/collects/planet2/lib.rkt index 9c755c8369..a7c76dc87b 100644 --- a/collects/planet2/lib.rkt +++ b/collects/planet2/lib.rkt @@ -1062,7 +1062,7 @@ (unless (directory-exists? dir) (pkg-error "directory does not exist\n path: ~a" dir)) (match create:format - ["MANIFEST" + ['MANIFEST (with-output-to-file (build-path dir "MANIFEST") #:exists 'replace @@ -1079,7 +1079,7 @@ (path->string (file-name-from-path pkg)) "")) (match create:format - ["tgz" + ['tgz (define pkg/complete (path->complete-path pkg)) (when (file-exists? pkg/complete) (delete-file pkg/complete)) @@ -1089,7 +1089,7 @@ (delete-file pkg/complete)) (raise exn))]) (apply tar-gzip pkg/complete (directory-list))))] - ["zip" + ['zip (define pkg/complete (path->complete-path pkg)) (when (file-exists? pkg/complete) (delete-file pkg/complete)) @@ -1099,7 +1099,7 @@ (delete-file pkg/complete)) (raise exn))]) (apply zip pkg/complete (directory-list))))] - ["plt" + ['plt (define dest (path->complete-path pkg)) (parameterize ([current-directory dir]) (define names (filter std-filter (directory-list))) @@ -1140,7 +1140,7 @@ (-> boolean? list? void?)] [create-cmd - (-> string? path-string? + (-> (or/c 'zip 'tgz 'plt 'MANIFEST) path-string? void?)] [update-packages (->* ((listof string?)) diff --git a/collects/planet2/main.rkt b/collects/planet2/main.rkt index 37cc667249..52cac96ae4 100644 --- a/collects/planet2/main.rkt +++ b/collects/planet2/main.rkt @@ -27,18 +27,23 @@ "This tool is used for managing installed packages." [install "Install packages" - [(#:sym #f) type ("-t") ("Type of ;" - "options are: file, dir, file-url, dir-url, github, or name;" - "if not specified, the type is inferred syntactically")] - [(#:str #f) name ("-n") ("Name of package, instead of inferred" - "(makes sense only when a single is given)")] - [#:bool no-setup () ("Don't run 'raco setup' after changing packages" + #:once-each + [(#:sym type [file dir file-url dir-url github name] #f) type ("-t") + ("Type of ;" + "valid s are: file, dir, file-url, dir-url, github, or name;" + "if not specified, the type is inferred syntactically")] + [(#:str name #f) name ("-n") ("Name of package, instead of inferred" + "(makes sense only when a single is given)")] + [#:bool no-setup () ("Don't run `raco setup' after changing packages" "(generally not a good idea)")] - [#:bool installation ("-i") "Operate on the installation-wide package database"] - [#:bool shared ("-s") "Install user-specific packages as shared for all versions"] - [(#:sym #f) deps () + #:once-any + [#:bool installation ("-i") "Install for all users of the Racket installation"] + [#:bool shared ("-s") "Install as user-specific but shared for all Racket versions"] + [#:bool user ("-u") "Install as user- and version-specific (the default)"] + #:once-each + [(#:sym mode [fail force search-ask search-auto] #f) deps () ("Specify the behavior for dependencies;" - "options are:" + "valid s are:" " fail: cancels the installation if dependencies are unmet" " (default for most packages)" " force: installs the package despite missing dependencies" @@ -63,15 +68,19 @@ (setup no-setup installation setup-collects)))] [update "Update packages" - [#:bool no-setup () ("Don't run 'raco setup' after changing packages" + #:once-each + [#:bool no-setup () ("Don't run `raco setup' after changing packages" "(generally not a good idea)")] - [#:bool installation ("-i") "Operate on the installation-wide package database"] - [#:bool shared ("-s") "Operate on the user-specific all-version package database"] + #:once-any + [#:bool installation ("-i") "Update only for all users of the Racket installation"] + [#:bool shared ("-s") "Update only user-specific packages for all Racket versions"] + [#:bool user ("-u") "Update only user- and version-specific packages (the default)"] + #:once-each [#:bool all ("-a") ("Update all packages;" "only if no packages are given on the command line")] - [(#:sym #f) deps () + [(#:sym mode [fail force search-ask search-auto] #f) deps () ("Specify the behavior for dependencies;" - "options are:" + "valid s are:" " fail: cancels the installation if dependencies are unmet" " (default for most packages)" " force: installs the package despite missing dependencies" @@ -94,10 +103,14 @@ (setup no-setup installation setup-collects))))] [remove "Remove packages" - [#:bool no-setup () ("Don't run 'raco setup' after changing packages" + #:once-each + [#:bool no-setup () ("Don't run `raco setup' after changing packages" "(generally not a good idea)")] - [#:bool installation ("-i") "Operate on the installation-wide package database"] - [#:bool shared ("-s") "Operate on the user-specific all-version package database"] + #:once-any + [#:bool installation ("-i") "Remove packages for all users of the Racket installation"] + [#:bool shared ("-s") "Remove user-specific packages for all Racket versions"] + [#:bool user ("-u") "Remove user- and version-specific packages (the default)"] + #:once-each [#:bool force () "Force removal of packages"] [#:bool auto () "Remove automatically installed packages with no dependencies"] #:args pkgs @@ -111,10 +124,11 @@ (setup no-setup installation #f)))] [show "Show information about installed packages" - [#:bool installation ("-i") "Show only the installation-wide package database"] - [#:bool shared ("-s") "Show only the user-specific all-version package database"] - [#:bool user ("-u") "Show only the user- and version-specific package database"] - [(#:str #f) version ("-v") "Show only user--specific packages for specified version"] + #:once-any + [#:bool installation ("-i") "Show only for all users of the Racket installation"] + [#:bool shared ("-s") "Show only user-specific for all Racket versions"] + [#:bool user ("-u") "Show only the user- and version-specific"] + [(#:str vers #f) version ("-v") "Show only user-specific for Racket "] #:args () (define only-mode (cond [installation 'i] @@ -136,8 +150,11 @@ (show-cmd (if only-mode "" " "))))))] [config "View and modify the package configuration" + #:once-any [#:bool installation ("-i") "Operate on the installation-wide package database"] [#:bool shared ("-s") "Operate on the user-specific all-version package database"] + [#:bool user ("-u") "Operate on the user-specific, version-specific package database"] + #:once-each [#:bool set () "Completely replace the value"] #:args key+vals (parameterize ([current-install-system-wide? installation] @@ -147,10 +164,11 @@ (config-cmd set key+vals)))] [create "Bundle a new package" - [(#:str #f) format () + #:once-any + [(#:sym fmt [zip tgz plt] #f) format () ("Select the format of the package to be created;" - "options are: zip (the default), tgz, plt")] + "valid s are: zip (the default), tgz, plt")] [#:bool manifest () "Creates a manifest file for a directory, rather than an archive"] #:args (maybe-dir) (parameterize ([current-pkg-error (pkg-error 'create)]) - (create-cmd (if manifest "MANIFEST" (or format "zip")) maybe-dir))]) + (create-cmd (if manifest 'MANIFEST (or format 'zip)) maybe-dir))]) diff --git a/collects/planet2/scribblings/planet2.scrbl b/collects/planet2/scribblings/planet2.scrbl index 03873aae96..e9e565a10d 100644 --- a/collects/planet2/scribblings/planet2.scrbl +++ b/collects/planet2/scribblings/planet2.scrbl @@ -229,8 +229,9 @@ sub-sub-commands: @item{@DFlag{no-setup} --- Does not run @exec{raco setup} after installation. This behavior is also the case if the environment variable @envvar{PLT_PLANET2_NOSETUP} is set to any non-empty value.} - @item{@DFlag{installation} or @Flag{i} --- Install system-wide, rather than user-local.} - @item{@DFlag{shared} or @Flag{s} --- Install for all Racket versions, rather than user-local and version-specific.} + @item{@DFlag{installation} or @Flag{i} --- Install packages for all users of a Racket installation, rather than user-specific.} + @item{@DFlag{shared} or @Flag{s} --- Install packages as user-specific, but for all Racket versions.} + @item{@DFlag{user} or @Flag{u} --- Install packages as user-specific and Racket version-specific (the default).} @item{@DFlag{deps} @nonterm{behavior} --- Selects the behavior for dependencies, where @nonterm{behavior} is one of @itemlist[ @@ -262,6 +263,7 @@ the following @nonterm{option}s: @item{@DFlag{no-setup} --- Same as for @exec{install}.} @item{@DFlag{installation} or @Flag{i} --- Same as for @exec{install}.} @item{@DFlag{shared} or @Flag{s} --- Same as for @exec{install}.} + @item{@DFlag{user} or @Flag{u} --- Same as for @exec{install} (the default).} @item{@DFlag{deps} @nonterm{behavior} --- Same as for @exec{install}.} @item{@DFlag{all} or @Flag{a} --- Update all packages, if no packages are given in the argument list.} @item{@DFlag{update-deps} --- Checks the named packages, and their dependencies (transitively) for updates.} @@ -276,6 +278,7 @@ listed, this command fails atomically. It accepts the following @nonterm{option} @item{@DFlag{no-setup} --- Same as for @exec{install}.} @item{@DFlag{installation} or @Flag{i} --- Same as for @exec{install}.} @item{@DFlag{shared} or @Flag{s} --- Same as for @exec{install}.} + @item{@DFlag{user} or @Flag{u} --- Same as for @exec{install} (the default).} @item{@DFlag{force} --- Ignore dependencies when removing packages.} @item{@DFlag{auto} --- Remove packages that were installed by the @exec{search-auto} or @exec{search-ask} dependency behavior and are no longer required.} @@ -289,8 +292,8 @@ listed, this command fails atomically. It accepts the following @nonterm{option} @itemlist[ @item{@DFlag{installation} or @Flag{i} --- Show only installation-wide packages.} - @item{@DFlag{user} or @Flag{u} --- Show only user-specific, version-specific packages.} @item{@DFlag{shared} or @Flag{s} --- Show only user-specific, all-version packages.} + @item{@DFlag{user} or @Flag{u} --- Show only user-specific, version-specific packages.} @item{@DFlag{version} @nonterm{vers} or @Flag{v} @nonterm{vers} --- Show only user-specific packages for Racket version @nonterm{vers}.} ] } @@ -301,6 +304,7 @@ View and modify package configuration options. It accepts the following @nonterm @itemlist[ @item{@DFlag{installation} or @Flag{i} --- Same as for @exec{install}.} @item{@DFlag{shared} or @Flag{s} --- Same as for @exec{install}.} + @item{@DFlag{user} or @Flag{u} --- Same as for @exec{install} (the default).} @item{@DFlag{set} --- Sets an option, rather than printing it.} ] @@ -328,9 +332,8 @@ View and modify package configuration options. It accepts the following @nonterm The @racketmodname[planet2] module provides a programmatic interface to the command sub-sub-commands. Each long form option is keyword -argument. An argument corresponding to @DFlag{type} or @DFlag{deps} -accepts its argument as a symbol, and @DFlag{format} accepts its -argument as a string. All other options accept booleans, where +argument. An argument corresponding to @DFlag{type}, @DFlag{deps}, or @DFlag{format} +accepts its argument as a symbol. All other options accept booleans, where @racket[#t] is equivalent to the presence of the option. @deftogether[