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

improve `raco pkg' text

Browse Source
This commit is contained in:
Matthew Flatt 2013-07-12 09:51:58 -06:00
parent 72ae9a1249
commit e8e482acaa
1 changed files with 82 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

141
racket/lib/collects/pkg/lib.rkt
View File

@ -318,10 +318,12 @@
(list (list
(cons 'version (version))))])) (cons 'version (version))))]))
(define (package-catalog-lookup pkg details?) (define (package-catalog-lookup pkg details? download-printf)
(or (or
(for/or ([i (in-list (pkg-catalogs))]) (for/or ([i (in-list (pkg-catalogs))])
(log-pkg-debug "consulting catalog ~a" (url->string i)) (if download-printf
(download-printf "Resolving ~s via ~a\n" pkg (url->string i))
(log-pkg-debug "consulting catalog ~a" (url->string i)))
(catalog-dispatch (catalog-dispatch
i i
;; Server: ;; Server:
@ -374,7 +376,7 @@
(define (remote-package-checksum pkg download-printf) (define (remote-package-checksum pkg download-printf)
(match pkg (match pkg
[`(catalog ,pkg-name) [`(catalog ,pkg-name)
(hash-ref (package-catalog-lookup pkg-name #f) 'checksum)] (hash-ref (package-catalog-lookup pkg-name #f download-printf) 'checksum)]
[`(url ,pkg-url-str) [`(url ,pkg-url-str)
(package-url->checksum pkg-url-str (package-url->checksum pkg-url-str
#:download-printf download-printf)])) #:download-printf download-printf)]))
@ -820,7 +822,7 @@
(values package-path (values package-path
'dir 'dir
(λ () (λ ()
(download-printf "\tCloning remote directory ~a\n" (download-printf "Cloning remote directory ~a\n"
(url->string pkg-url)) (url->string pkg-url))
(make-directory* package-path) (make-directory* package-path)
(define manifest (define manifest
@ -845,6 +847,7 @@
(values package-path (values package-path
'file 'file
(λ () (λ ()
(download-printf "Downloading ~a\n" (url->string pkg-url))
(log-pkg-debug "\tAssuming URL names a file") (log-pkg-debug "\tAssuming URL names a file")
(download-file! pkg-url package-path)))])) (download-file! pkg-url package-path)))]))
(dynamic-wind (dynamic-wind
@ -984,7 +987,7 @@
#f #f
(directory->module-paths pkg-dir pkg-name metadata-ns))]))] (directory->module-paths pkg-dir pkg-name metadata-ns))]))]
[(eq? type 'name) [(eq? type 'name)
(define catalog-info (package-catalog-lookup pkg #f)) (define catalog-info (package-catalog-lookup pkg #f download-printf))
(define source (hash-ref catalog-info 'source)) (define source (hash-ref catalog-info 'source))
(define checksum (hash-ref catalog-info 'checksum)) (define checksum (hash-ref catalog-info 'checksum))
(define info (stage-package/info source (define info (stage-package/info source
@ -1024,6 +1027,24 @@
(install-info-clean? i) (install-info-clean? i)
(install-info-module-paths i))) (install-info-module-paths i)))
(define (ask question)
(let loop ()
(printf question)
(printf " [Y/n/a/?] ")
(flush-output)
(match (read-line)
[(or "y" "Y" "")
'yes]
[(or "n" "N")
'no]
[(or "a" "A")
'always-yes]
[x
(eprintf "Invalid answer: ~a\n" x)
(eprintf " Answer nothing or `y' or `Y' for \"yes\", `n' or `N' for \"no\", or\n")
(eprintf " `a' or `A' for \"yes for all\".\n")
(loop)])))
(define (install-packages (define (install-packages
#:old-infos [old-infos empty] #:old-infos [old-infos empty]
#:old-descs [old-descs empty] #:old-descs [old-descs empty]
@ -1034,6 +1055,8 @@
#:skip-installed? [skip-installed? #f] #:skip-installed? [skip-installed? #f]
#:force? [force? #f] #:force? [force? #f]
#:quiet? [quiet? #f] #:quiet? [quiet? #f]
#:install-conversation [install-conversation #f]
#:update-conversation [update-conversation #f]
descs) descs)
(define download-printf (if quiet? void printf)) (define download-printf (if quiet? void printf))
(define check-sums? (not ignore-checksums?)) (define check-sums? (not ignore-checksums?))
@ -1048,6 +1071,25 @@
(define (clean!) (define (clean!)
(when clean? (when clean?
(delete-directory/files pkg-dir))) (delete-directory/files pkg-dir)))
(define (format-deps update-deps)
(format-list (for/list ([ud (in-list update-deps)])
(format "~a (have ~a, need ~a)"
(car ud)
(caddr ud)
(cadddr ud)))))
(define (show-dependencies deps update? auto? conversation)
(unless quiet?
(printf "The following ~a packages are listed as dependencies of ~a~a:~a\n"
(if update? "out-of-date" "uninstalled")
pkg-name
(if (or auto? (eq? conversation 'always-yes))
(format "\nand they will be ~a~a"
(if auto? "automatically " "")
(if update? "updated" "installed"))
"")
(if update?
(format-deps deps)
(format-list deps)))))
(define simultaneous-installs (define simultaneous-installs
(for/hash ([i (in-list infos)]) (for/hash ([i (in-list infos)])
(values (install-info-name i) (install-info-directory i)))) (values (install-info-name i) (install-info-directory i))))
@ -1130,32 +1172,20 @@
pkg pkg
(format-list unsatisfied-deps))] (format-list unsatisfied-deps))]
['search-auto ['search-auto
(printf (string-append (show-dependencies unsatisfied-deps #f #t install-conversation)
"The following packages are listed as dependencies, but are not currently installed,\n" (raise (vector updating? infos unsatisfied-deps void 'always-yes update-conversation))]
"so they will be automatically installed:\n"))
(printf "\t")
(for ([p (in-list unsatisfied-deps)])
(printf "~a " p))
(printf "\n")
(raise (vector updating? infos unsatisfied-deps void))]
['search-ask ['search-ask
(printf "The following packages are listed as dependencies, but are not currently installed:\n") (show-dependencies unsatisfied-deps #f #f install-conversation)
(printf "\t") (case (if (eq? install-conversation 'always-yes)
(for ([p (in-list unsatisfied-deps)]) 'always-yes
(printf "~a " p)) (ask "Would you like to install these dependencies?"))
(printf "\n") [(yes)
(let loop () (raise (vector updating? infos unsatisfied-deps void 'again update-conversation))]
(printf "Would you like to install them via your package catalogs? [Yn] ") [(always-yes)
(flush-output) (raise (vector updating? infos unsatisfied-deps void 'always-yes update-conversation))]
(match (read-line) [(no)
[(or "y" "Y" "") (clean!)
(raise (vector updating? infos unsatisfied-deps void))] (pkg-error "missing dependencies\n missing packages:~a" (format-list unsatisfied-deps))])]))]
[(or "n" "N")
(clean!)
(pkg-error "missing dependencies\n missing packages:~a" (format-list unsatisfied-deps))]
[x
(eprintf "Invalid input: ~e\n" x)
(loop)]))]))]
[(and [(and
(not (eq? dep-behavior 'force)) (not (eq? dep-behavior 'force))
(let () (let ()
@ -1212,12 +1242,6 @@
(if multi? "ies" "y") (if multi? "ies" "y")
pkg pkg
(format-deps update-deps))) (format-deps update-deps)))
(define (format-deps update-deps)
(format-list (for/list ([ud (in-list update-deps)])
(format "~a (have ~a, need ~a)"
(car ud)
(caddr ud)
(cadddr ud)))))
;; If there's a mismatch that we can't attempt to update, complain. ;; If there's a mismatch that we can't attempt to update, complain.
(unless (andmap cadr update-deps) (unless (andmap cadr update-deps)
(report-mismatch (filter (compose not cadr) update-deps))) (report-mismatch (filter (compose not cadr) update-deps)))
@ -1234,27 +1258,20 @@
(clean!) (clean!)
(report-mismatch update-deps)] (report-mismatch update-deps)]
['search-auto ['search-auto
(printf (string-append (show-dependencies update-deps #t #t update-conversation)
"The following packages are listed as dependencies, but are not at the required\n" (raise (vector #t infos update-pkgs (make-pre-succeed) install-conversation 'always-yes))]
"version, so they will be automatically updated:~a\n")
(format-deps update-deps))
(raise (vector #t infos update-pkgs (make-pre-succeed)))]
['search-ask ['search-ask
(printf (~a "The following packages are listed as dependencies, but are not at the required\n" (show-dependencies update-deps #t #f update-conversation)
"versions:~a\n") (case (if (eq? update-conversation 'always-yes)
(format-deps update-deps)) 'always-yes
(let loop () (ask "Would you like to update these dependencies?"))
(printf "Would you like to update them via your package catalogs? [Yn] ") [(yes)
(flush-output) (raise (vector #t infos update-pkgs (make-pre-succeed) install-conversation 'again))]
(match (read-line) [(always-yes)
[(or "y" "Y" "") (raise (vector #t infos update-pkgs (make-pre-succeed) install-conversation 'always-yes))]
(raise (vector #t infos update-pkgs (make-pre-succeed)))] [(no)
[(or "n" "N") (clean!)
(clean!) (report-mismatch update-deps)])]))]
(report-mismatch update-deps)]
[x
(eprintf "Invalid input: ~e\n" x)
(loop)]))]))]
[else [else
(λ () (λ ()
(define final-pkg-dir (define final-pkg-dir
@ -1377,7 +1394,9 @@
#:pre-succeed [pre-succeed void] #:pre-succeed [pre-succeed void]
#:dep-behavior [dep-behavior #f] #:dep-behavior [dep-behavior #f]
#:updating? [updating? #f] #:updating? [updating? #f]
#:quiet? [quiet? #f]) #:quiet? [quiet? #f]
#:install-conversation [install-conversation #f]
#:update-conversation [update-conversation #f])
(define new-descs (define new-descs
(remove-duplicates (remove-duplicates
(if (not skip-installed?) (if (not skip-installed?)
@ -1395,7 +1414,7 @@
pkg-desc=?)) pkg-desc=?))
(with-handlers* ([vector? (with-handlers* ([vector?
(match-lambda (match-lambda
[(vector updating? new-infos deps more-pre-succeed) [(vector updating? new-infos deps more-pre-succeed inst-conv updt-conv)
(pkg-install (pkg-install
#:old-infos new-infos #:old-infos new-infos
#:old-auto+pkgs (append old-descs new-descs) #:old-auto+pkgs (append old-descs new-descs)
@ -1404,6 +1423,8 @@
#:dep-behavior dep-behavior #:dep-behavior dep-behavior
#:pre-succeed (lambda () (pre-succeed) (more-pre-succeed)) #:pre-succeed (lambda () (pre-succeed) (more-pre-succeed))
#:updating? updating? #:updating? updating?
#:install-conversation inst-conv
#:update-conversation updt-conv
(for/list ([dep (in-list deps)]) (for/list ([dep (in-list deps)])
(pkg-desc dep #f #f #t)))])]) (pkg-desc dep #f #f #t)))])])
(install-packages (install-packages
@ -1416,6 +1437,8 @@
#:pre-succeed pre-succeed #:pre-succeed pre-succeed
#:updating? updating? #:updating? updating?
#:quiet? quiet? #:quiet? quiet?
#:install-conversation install-conversation
#:update-conversation update-conversation
new-descs))) new-descs)))
(define (update-is-possible? pkg-name) (define (update-is-possible? pkg-name)
@ -1921,7 +1944,7 @@
(define (get-pkg-details-from-catalogs name) (define (get-pkg-details-from-catalogs name)
(for/or ([i (in-list (pkg-catalogs))]) (for/or ([i (in-list (pkg-catalogs))])
(package-catalog-lookup name #t))) (package-catalog-lookup name #t #f)))
(define (get-all-pkg-details-from-catalogs) (define (get-all-pkg-details-from-catalogs)
(for/fold ([ht (hash)]) ([i (in-list (pkg-catalogs))]) (for/fold ([ht (hash)]) ([i (in-list (pkg-catalogs))])