;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com>
;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net>
+;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;; Avoid "overrides core binding" warning.
delete))
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
(('unbound-variable _ ...)
(report-unbound-variable-error args #:frame frame))
(((or 'srfi-34 '%exception) obj)
- (if (message-condition? obj)
- (report-error (and (error-location? obj)
- (error-location obj))
- (G_ "~a~%")
- (gettext (condition-message obj) %gettext-domain))
- (report-error (G_ "exception thrown: ~s~%") obj))
+ (cond ((message-condition? obj)
+ (report-error (and (error-location? obj)
+ (error-location obj))
+ (G_ "~a~%")
+ (gettext (condition-message obj) %gettext-domain)))
+ ((formatted-message? obj)
+ (apply report-error
+ (and (error-location? obj) (error-location obj))
+ (gettext (formatted-message-string obj) %gettext-domain)
+ (formatted-message-arguments obj)))
+ (else
+ (report-error (G_ "exception thrown: ~s~%") obj)))
(when (fix-hint? obj)
(display-hint (condition-fix-hint obj))))
((key args ...)
(('unbound-variable _ ...)
(report-unbound-variable-error args))
(((or 'srfi-34 '%exception) obj)
- (if (message-condition? obj)
- (warning (G_ "failed to load '~a': ~a~%")
- file
- (gettext (condition-message obj) %gettext-domain))
- (warning (G_ "failed to load '~a': exception thrown: ~s~%")
- file obj)))
+ (cond ((message-condition? obj)
+ (warning (G_ "failed to load '~a': ~a~%")
+ file
+ (gettext (condition-message obj) %gettext-domain)))
+ ((formatted-message? obj)
+ (warning (G_ "failed to load '~a': ~a~%")
+ (apply format #f
+ (gettext (formatted-message-string obj)
+ %gettext-domain)
+ (formatted-message-arguments obj))))
+ (else
+ (warning (G_ "failed to load '~a': exception thrown: ~s~%")
+ file obj))))
((error args ...)
(warning (G_ "failed to load '~a':~%") module)
(apply display-error #f (current-error-port) args)
export GUIX_LOCPATH=\"$HOME/.guix-profile/lib/locale\"
@end example
-See the \"Application Setup\" section in the manual, for more info.\n")))))
+See the \"Application Setup\" section in the manual, for more info.\n"))
+ ;; We're now running in the "C" locale. Try to install a UTF-8 locale
+ ;; instead. This one is guaranteed to be available in 'guix' from 'guix
+ ;; pull'.
+ (false-if-exception (setlocale LC_ALL "en_US.utf8")))))
(define (initialize-guix)
"Perform the usual initialization for stand-alone Guix commands."
Report bugs to: ~a.") %guix-bug-report-address)
(format #t (G_ "
~a home page: <~a>") %guix-package-name %guix-home-page-url)
- (display (G_ "
-General help using GNU software: <http://www.gnu.org/gethelp/>"))
+ (format #t (G_ "
+General help using Guix and GNU software: <~a>")
+ "https://guix.gnu.org/help/")
(newline))
(define (augmented-system-error-handler file)
or remove one of them from the profile.")
name1 name2)))))
+(cond-expand
+ (guile-3
+ ;; On Guile 3.0, in 'call-with-error-handling' we need to re-raise. To
+ ;; preserve useful backtraces in case of unhandled errors, we want that to
+ ;; happen before the stack has been unwound, hence 'guard*'.
+ (define-syntax-rule (guard* (var clauses ...) exp ...)
+ "This variant of SRFI-34 'guard' does not unwind the stack before
+evaluating the tests and bodies of CLAUSES."
+ (with-exception-handler
+ (lambda (var)
+ (cond clauses ... (else (raise var))))
+ (lambda () exp ...)
+ #:unwind? #f)))
+ (else
+ (define-syntax-rule (guard* (var clauses ...) exp ...)
+ (guard (var clauses ...) exp ...))))
+
(define (call-with-error-handling thunk)
"Call THUNK within a user-friendly error handler."
(define (port-filename* port)
(and (not (port-closed? port))
(port-filename port)))
- (guard (c ((package-input-error? c)
- (let* ((package (package-error-package c))
- (input (package-error-invalid-input c))
- (location (package-location package))
- (file (location-file location))
- (line (location-line location))
- (column (location-column location)))
- (leave (G_ "~a:~a:~a: package `~a' has an invalid input: ~s~%")
- file line column
- (package-full-name package) input)))
- ((package-cross-build-system-error? c)
- (let* ((package (package-error-package c))
- (loc (package-location package))
- (system (package-build-system package)))
- (leave (G_ "~a: ~a: build system `~a' does not support cross builds~%")
- (location->string loc)
- (package-full-name package)
- (build-system-name system))))
- ((gexp-input-error? c)
- (let ((input (package-error-invalid-input c)))
- (leave (G_ "~s: invalid G-expression input~%")
- (gexp-error-invalid-input c))))
- ((profile-not-found-error? c)
- (leave (G_ "profile '~a' does not exist~%")
- (profile-error-profile c)))
- ((missing-generation-error? c)
- (leave (G_ "generation ~a of profile '~a' does not exist~%")
- (missing-generation-error-generation c)
- (profile-error-profile c)))
- ((unmatched-pattern-error? c)
- (let ((pattern (unmatched-pattern-error-pattern c)))
- (leave (G_ "package '~a~@[@~a~]~@[:~a~]' not found in profile~%")
- (manifest-pattern-name pattern)
- (manifest-pattern-version pattern)
- (match (manifest-pattern-output pattern)
- ("out" #f)
- (output output)))))
- ((profile-collision-error? c)
- (let ((entry (profile-collision-error-entry c))
- (conflict (profile-collision-error-conflict c)))
- (define (report-parent-entries entry)
- (let ((parent (force (manifest-entry-parent entry))))
- (when (manifest-entry? parent)
- (report-error (G_ " ... propagated from ~a@~a~%")
- (manifest-entry-name parent)
- (manifest-entry-version parent))
- (report-parent-entries parent))))
-
- (define (manifest-entry-output* entry)
- (match (manifest-entry-output entry)
- ("out" "")
- (output (string-append ":" output))))
-
- (report-error (G_ "profile contains conflicting entries for ~a~a~%")
- (manifest-entry-name entry)
- (manifest-entry-output* entry))
- (report-error (G_ " first entry: ~a@~a~a ~a~%")
- (manifest-entry-name entry)
- (manifest-entry-version entry)
- (manifest-entry-output* entry)
- (manifest-entry-item entry))
- (report-parent-entries entry)
- (report-error (G_ " second entry: ~a@~a~a ~a~%")
- (manifest-entry-name conflict)
- (manifest-entry-version conflict)
- (manifest-entry-output* conflict)
- (manifest-entry-item conflict))
- (report-parent-entries conflict)
- (display-collision-resolution-hint c)
- (exit 1)))
- ((nar-error? c)
- (let ((file (nar-error-file c))
- (port (nar-error-port c)))
- (if file
- (leave (G_ "corrupt input while restoring '~a' from ~s~%")
- file (or (port-filename* port) port))
- (leave (G_ "corrupt input while restoring archive from ~s~%")
- (or (port-filename* port) port)))))
- ((store-connection-error? c)
- (leave (G_ "failed to connect to `~a': ~a~%")
- (store-connection-error-file c)
- (strerror (store-connection-error-code c))))
- ((store-protocol-error? c)
- ;; FIXME: Server-provided error messages aren't i18n'd.
- (leave (G_ "~a~%")
- (store-protocol-error-message c)))
- ((derivation-missing-output-error? c)
- (leave (G_ "reference to invalid output '~a' of derivation '~a'~%")
- (derivation-missing-output c)
- (derivation-file-name (derivation-error-derivation c))))
- ((file-search-error? c)
- (leave (G_ "file '~a' could not be found in these \
+ (guard* (c ((package-input-error? c)
+ (let* ((package (package-error-package c))
+ (input (package-error-invalid-input c))
+ (location (package-location package))
+ (file (location-file location))
+ (line (location-line location))
+ (column (location-column location)))
+ (leave (G_ "~a:~a:~a: package `~a' has an invalid input: ~s~%")
+ file line column
+ (package-full-name package) input)))
+ ((package-cross-build-system-error? c)
+ (let* ((package (package-error-package c))
+ (loc (package-location package))
+ (system (package-build-system package)))
+ (leave (G_ "~a: ~a: build system `~a' does not support cross builds~%")
+ (location->string loc)
+ (package-full-name package)
+ (build-system-name system))))
+ ((gexp-input-error? c)
+ (let ((input (package-error-invalid-input c)))
+ (leave (G_ "~s: invalid G-expression input~%")
+ (gexp-error-invalid-input c))))
+ ((profile-not-found-error? c)
+ (leave (G_ "profile '~a' does not exist~%")
+ (profile-error-profile c)))
+ ((missing-generation-error? c)
+ (leave (G_ "generation ~a of profile '~a' does not exist~%")
+ (missing-generation-error-generation c)
+ (profile-error-profile c)))
+ ((unmatched-pattern-error? c)
+ (let ((pattern (unmatched-pattern-error-pattern c)))
+ (leave (G_ "package '~a~@[@~a~]~@[:~a~]' not found in profile~%")
+ (manifest-pattern-name pattern)
+ (manifest-pattern-version pattern)
+ (match (manifest-pattern-output pattern)
+ ("out" #f)
+ (output output)))))
+ ((profile-collision-error? c)
+ (let ((entry (profile-collision-error-entry c))
+ (conflict (profile-collision-error-conflict c)))
+ (define (report-parent-entries entry)
+ (let ((parent (force (manifest-entry-parent entry))))
+ (when (manifest-entry? parent)
+ (report-error (G_ " ... propagated from ~a@~a~%")
+ (manifest-entry-name parent)
+ (manifest-entry-version parent))
+ (report-parent-entries parent))))
+
+ (define (manifest-entry-output* entry)
+ (match (manifest-entry-output entry)
+ ("out" "")
+ (output (string-append ":" output))))
+
+ (report-error (G_ "profile contains conflicting entries for ~a~a~%")
+ (manifest-entry-name entry)
+ (manifest-entry-output* entry))
+ (report-error (G_ " first entry: ~a@~a~a ~a~%")
+ (manifest-entry-name entry)
+ (manifest-entry-version entry)
+ (manifest-entry-output* entry)
+ (manifest-entry-item entry))
+ (report-parent-entries entry)
+ (report-error (G_ " second entry: ~a@~a~a ~a~%")
+ (manifest-entry-name conflict)
+ (manifest-entry-version conflict)
+ (manifest-entry-output* conflict)
+ (manifest-entry-item conflict))
+ (report-parent-entries conflict)
+ (display-collision-resolution-hint c)
+ (exit 1)))
+ ((nar-error? c)
+ (let ((file (nar-error-file c))
+ (port (nar-error-port c)))
+ (if file
+ (leave (G_ "corrupt input while restoring '~a' from ~s~%")
+ file (or (port-filename* port) port))
+ (leave (G_ "corrupt input while restoring archive from ~s~%")
+ (or (port-filename* port) port)))))
+ ((store-connection-error? c)
+ (leave (G_ "failed to connect to `~a': ~a~%")
+ (store-connection-error-file c)
+ (strerror (store-connection-error-code c))))
+ ((store-protocol-error? c)
+ ;; FIXME: Server-provided error messages aren't i18n'd.
+ (leave (G_ "~a~%")
+ (store-protocol-error-message c)))
+ ((derivation-missing-output-error? c)
+ (leave (G_ "reference to invalid output '~a' of derivation '~a'~%")
+ (derivation-missing-output c)
+ (derivation-file-name (derivation-error-derivation c))))
+ ((file-search-error? c)
+ (leave (G_ "file '~a' could not be found in these \
directories:~{ ~a~}~%")
- (file-search-error-file-name c)
- (file-search-error-search-path c)))
- ((invoke-error? c)
- (leave (G_ "program exited\
+ (file-search-error-file-name c)
+ (file-search-error-search-path c)))
+ ((invoke-error? c)
+ (leave (G_ "program exited\
~@[ with non-zero exit status ~a~]\
~@[ terminated by signal ~a~]\
~@[ stopped by signal ~a~]: ~s~%")
- (invoke-error-exit-status c)
- (invoke-error-term-signal c)
- (invoke-error-stop-signal c)
- (cons (invoke-error-program c)
- (invoke-error-arguments c))))
- ((and (error-location? c) (message-condition? c))
- (report-error (error-location c) (G_ "~a~%")
- (gettext (condition-message c) %gettext-domain))
- (when (fix-hint? c)
- (display-hint (condition-fix-hint c)))
- (exit 1))
- ((and (message-condition? c) (fix-hint? c))
- (report-error (G_ "~a~%")
- (gettext (condition-message c) %gettext-domain))
- (display-hint (condition-fix-hint c))
- (exit 1))
-
- ;; On Guile 3.0.0, exceptions such as 'unbound-variable' are
- ;; compound and include a '&message'. However, that message only
- ;; contains the format string. Thus, special-case it here to
- ;; avoid displaying a bare format string.
- ((cond-expand
- (guile-3
- ((exception-predicate &exception-with-kind-and-args) c))
- (else #f))
- (raise c))
-
- ((message-condition? c)
- ;; Normally '&message' error conditions have an i18n'd message.
- (leave (G_ "~a~%")
- (gettext (condition-message c) %gettext-domain))))
- ;; Catch EPIPE and the likes.
- (catch 'system-error
- thunk
- (lambda (key proc format-string format-args . rest)
- (leave (G_ "~a: ~a~%") proc
- (apply format #f format-string format-args))))))
+ (invoke-error-exit-status c)
+ (invoke-error-term-signal c)
+ (invoke-error-stop-signal c)
+ (cons (invoke-error-program c)
+ (invoke-error-arguments c))))
+
+ ((formatted-message? c)
+ (apply report-error
+ (and (error-location? c) (error-location c))
+ (gettext (formatted-message-string c) %gettext-domain)
+ (formatted-message-arguments c))
+ (when (fix-hint? c)
+ (display-hint (condition-fix-hint c)))
+ (exit 1))
+
+ ;; On Guile 3.0.0, exceptions such as 'unbound-variable' are
+ ;; compound and include a '&message'. However, that message only
+ ;; contains the format string. Thus, special-case it here to
+ ;; avoid displaying a bare format string.
+ ;;
+ ;; Furthermore, use of 'guard*' ensures that the stack has not
+ ;; been unwound when we re-raise, since that would otherwise show
+ ;; useless backtraces.
+ ((cond-expand
+ (guile-3
+ ((exception-predicate &exception-with-kind-and-args) c))
+ (else #f))
+ (raise c))
+
+ ((message-condition? c)
+ ;; Normally '&message' error conditions have an i18n'd message.
+ (report-error (and (error-location? c) (error-location c))
+ (G_ "~a~%")
+ (gettext (condition-message c) %gettext-domain))
+ (when (fix-hint? c)
+ (display-hint (condition-fix-hint c)))
+ (exit 1)))
+ ;; Catch EPIPE and the likes.
+ (catch 'system-error
+ thunk
+ (lambda (key proc format-string format-args . rest)
+ (leave (G_ "~a: ~a~%") proc
+ (apply format #f format-string format-args))))))
(define-syntax-rule (leave-on-EPIPE exp ...)
"Run EXP... in a context where EPIPE errors are caught and lead to 'exit'
(('syntax-error proc message properties form . rest)
(report-error (G_ "syntax error: ~a~%") message))
(((or 'srfi-34 '%exception) obj)
- (if (message-condition? obj)
- (report-error (G_ "~a~%")
- (gettext (condition-message obj)
- %gettext-domain))
- (report-error (G_ "exception thrown: ~s~%") obj)))
+ (cond ((message-condition? obj)
+ (report-error (G_ "~a~%")
+ (gettext (condition-message obj)
+ %gettext-domain)))
+ ((formatted-message? obj)
+ (apply report-error #f
+ (gettext (formatted-message-string obj)
+ %gettext-domain)
+ (formatted-message-arguments obj)))
+ (else
+ (report-error (G_ "exception thrown: ~s~%") obj))))
((error args ...)
(apply display-error #f (current-error-port) args))
(what? #f))
(color DARK))
(string-drop file prefix)))))
+(define %default-verbosity
+ ;; Default verbosity level for 'show-what-to-build'.
+ 2)
+
(define* (show-what-to-build store drv
#:key dry-run? (use-substitutes? #t)
+ (verbosity %default-verbosity)
(mode (build-mode normal)))
"Show what will or would (depending on DRY-RUN?) be built in realizing the
derivations listed in DRV using MODE, a 'build-mode' value. The elements of
DRV can be either derivations or derivation inputs.
Return two values: a Boolean indicating whether there's something to build,
-and a Boolean indicating whether there's something to download. When
-USE-SUBSTITUTES?, check and report what is prerequisites are available for
-download."
+and a Boolean indicating whether there's something to download.
+
+When USE-SUBSTITUTES?, check and report what is prerequisites are available
+for download. VERBOSITY is an integer indicating the level of details to be
+shown: level 2 and higher provide all the details, level 1 shows a high-level
+summary, and level 0 shows nothing."
(define inputs
(map (match-lambda
((? derivation? drv) (derivation-input drv))
;; display when we have information for all of DOWNLOAD.
(not (any (compose zero? substitutable-download-size) download)))
+ ;; Combinatorial explosion ahead along two axes: DRY-RUN? and VERBOSITY.
+ ;; Unfortunately, this is hardly avoidable for proper i18n.
(if dry-run?
(begin
- (format (current-error-port)
- (N_ "~:[The following derivation would be built:~%~{ ~a~%~}~;~]"
- "~:[The following derivations would be built:~%~{ ~a~%~}~;~]"
- (length build))
- (null? build) (map colorized-store-item build))
- (if display-download-size?
- (format (current-error-port)
- ;; TRANSLATORS: "MB" is for "megabyte"; it should be
- ;; translated to the corresponding abbreviation.
- (G_ "~:[~,1h MB would be downloaded:~%~{ ~a~%~}~;~]")
- (null? download)
- download-size
- (map (compose colorized-store-item substitutable-path)
- download))
- (format (current-error-port)
- (N_ "~:[The following file would be downloaded:~%~{ ~a~%~}~;~]"
- "~:[The following files would be downloaded:~%~{ ~a~%~}~;~]"
- (length download))
- (null? download)
- (map (compose colorized-store-item substitutable-path)
- download)))
- (format (current-error-port)
- (N_ "~:[The following graft would be made:~%~{ ~a~%~}~;~]"
- "~:[The following grafts would be made:~%~{ ~a~%~}~;~]"
- (length graft))
- (null? graft) (map colorized-store-item graft))
- (format (current-error-port)
- (N_ "~:[The following profile hook would be built:~%~{ ~a~%~}~;~]"
- "~:[The following profile hooks would be built:~%~{ ~a~%~}~;~]"
- (length hook))
- (null? hook) (map colorized-store-item hook)))
+ (unless (zero? verbosity)
+ (format (current-error-port)
+ (N_ "~:[The following derivation would be built:~%~{ ~a~%~}~;~]"
+ "~:[The following derivations would be built:~%~{ ~a~%~}~;~]"
+ (length build))
+ (null? build) (map colorized-store-item build)))
+ (cond ((>= verbosity 2)
+ (if display-download-size?
+ (format (current-error-port)
+ ;; TRANSLATORS: "MB" is for "megabyte"; it should be
+ ;; translated to the corresponding abbreviation.
+ (G_ "~:[~,1h MB would be downloaded:~%~{ ~a~%~}~;~]")
+ (null? download)
+ download-size
+ (map (compose colorized-store-item substitutable-path)
+ download))
+ (format (current-error-port)
+ (N_ "~:[The following file would be downloaded:~%~{ ~a~%~}~;~]"
+ "~:[The following files would be downloaded:~%~{ ~a~%~}~;~]"
+ (length download))
+ (null? download)
+ (map (compose colorized-store-item substitutable-path)
+ download)))
+ (format (current-error-port)
+ (N_ "~:[The following graft would be made:~%~{ ~a~%~}~;~]"
+ "~:[The following grafts would be made:~%~{ ~a~%~}~;~]"
+ (length graft))
+ (null? graft) (map colorized-store-item graft))
+ (format (current-error-port)
+ (N_ "~:[The following profile hook would be built:~%~{ ~a~%~}~;~]"
+ "~:[The following profile hooks would be built:~%~{ ~a~%~}~;~]"
+ (length hook))
+ (null? hook) (map colorized-store-item hook)))
+ ((= verbosity 1)
+ ;; Display the bare minimum; don't mention grafts and hooks.
+ (unless (null? build)
+ (newline (current-error-port)))
+ (if display-download-size?
+ (format (current-error-port)
+ ;; TRANSLATORS: "MB" is for "megabyte"; it should be
+ ;; translated to the corresponding abbreviation.
+ (highlight (G_ "~:[~,1h MB would be downloaded~%~;~]"))
+ (null? download) download-size)
+ (format (current-error-port)
+ (highlight
+ (N_ "~:[~h item would be downloaded~%~;~]"
+ "~:[~h items would be downloaded~%~;~]"
+ (length download)))
+ (null? download) (length download))))))
+
(begin
- (format (current-error-port)
- (N_ "~:[The following derivation will be built:~%~{ ~a~%~}~;~]"
- "~:[The following derivations will be built:~%~{ ~a~%~}~;~]"
- (length build))
- (null? build) (map colorized-store-item build))
- (if display-download-size?
- (format (current-error-port)
- ;; TRANSLATORS: "MB" is for "megabyte"; it should be
- ;; translated to the corresponding abbreviation.
- (G_ "~:[~,1h MB will be downloaded:~%~{ ~a~%~}~;~]")
- (null? download)
- download-size
- (map (compose colorized-store-item substitutable-path)
- download))
- (format (current-error-port)
- (N_ "~:[The following file will be downloaded:~%~{ ~a~%~}~;~]"
- "~:[The following files will be downloaded:~%~{ ~a~%~}~;~]"
- (length download))
- (null? download)
- (map (compose colorized-store-item substitutable-path)
- download)))
- (format (current-error-port)
- (N_ "~:[The following graft will be made:~%~{ ~a~%~}~;~]"
- "~:[The following grafts will be made:~%~{ ~a~%~}~;~]"
- (length graft))
- (null? graft) (map colorized-store-item graft))
- (format (current-error-port)
- (N_ "~:[The following profile hook will be built:~%~{ ~a~%~}~;~]"
- "~:[The following profile hooks will be built:~%~{ ~a~%~}~;~]"
- (length hook))
- (null? hook) (map colorized-store-item hook))))
+ (unless (zero? verbosity)
+ (format (current-error-port)
+ (N_ "~:[The following derivation will be built:~%~{ ~a~%~}~;~]"
+ "~:[The following derivations will be built:~%~{ ~a~%~}~;~]"
+ (length build))
+ (null? build) (map colorized-store-item build)))
+ (cond ((>= verbosity 2)
+ (if display-download-size?
+ (format (current-error-port)
+ ;; TRANSLATORS: "MB" is for "megabyte"; it should be
+ ;; translated to the corresponding abbreviation.
+ (G_ "~:[~,1h MB will be downloaded:~%~{ ~a~%~}~;~]")
+ (null? download)
+ download-size
+ (map (compose colorized-store-item substitutable-path)
+ download))
+ (format (current-error-port)
+ (N_ "~:[The following file will be downloaded:~%~{ ~a~%~}~;~]"
+ "~:[The following files will be downloaded:~%~{ ~a~%~}~;~]"
+ (length download))
+ (null? download)
+ (map (compose colorized-store-item substitutable-path)
+ download)))
+ (format (current-error-port)
+ (N_ "~:[The following graft will be made:~%~{ ~a~%~}~;~]"
+ "~:[The following grafts will be made:~%~{ ~a~%~}~;~]"
+ (length graft))
+ (null? graft) (map colorized-store-item graft))
+ (format (current-error-port)
+ (N_ "~:[The following profile hook will be built:~%~{ ~a~%~}~;~]"
+ "~:[The following profile hooks will be built:~%~{ ~a~%~}~;~]"
+ (length hook))
+ (null? hook) (map colorized-store-item hook)))
+ ((= verbosity 1)
+ ;; Display the bare minimum; don't mention grafts and hooks.
+ (unless (null? build)
+ (newline (current-error-port)))
+ (if display-download-size?
+ (format (current-error-port)
+ ;; TRANSLATORS: "MB" is for "megabyte"; it should be
+ ;; translated to the corresponding abbreviation.
+ (highlight (G_ "~:[~,1h MB will be downloaded~%~;~]"))
+ (null? download) download-size)
+ (format (current-error-port)
+ (highlight
+ (N_ "~:[~h item will be downloaded~%~;~]"
+ "~:[~h items will be downloaded~%~;~]"
+ (length download)))
+ (null? download) (length download)))))))
(check-available-space installed-size)
(define show-what-to-build*
(store-lift show-what-to-build))
-(define* (build-notifier #:key (dry-run? #f) (use-substitutes? #t))
+(define* (build-notifier #:key (dry-run? #f) (use-substitutes? #t)
+ (verbosity %default-verbosity))
"Return a procedure suitable for 'with-build-handler' that, when
'build-things' is called, invokes 'show-what-to-build' to display the build
plan. When DRY-RUN? is true, the 'with-build-handler' form returns without
(show-what-to-build store inputs
#:dry-run? dry-run?
#:use-substitutes? use-substitutes?
+ #:verbosity verbosity
#:mode mode)))
(unless (and (or build? download?)
(define* (show-manifest-transaction store manifest transaction
#:key dry-run?)
"Display what will/would be installed/removed from MANIFEST by TRANSACTION."
- (define (package-strings names versions outputs)
- (tabulate (zip (map (lambda (name output)
- (if (string=? output "out")
- name
- (string-append name ":" output)))
- names outputs)
- versions)
+ (define* (package-strings names versions outputs #:key old-versions)
+ (tabulate (stable-sort
+ (zip (map (lambda (name output)
+ (if (string=? output "out")
+ name
+ (string-append name ":" output)))
+ names outputs)
+ (if old-versions
+ (map (lambda (old new)
+ (if (string=? old new)
+ (G_ "(dependencies or package changed)")
+ (string-append old " " → " " new)))
+ old-versions versions)
+ versions))
+ (lambda (x y)
+ (string<? (first x) (first y))))
#:initial-indent 3))
(define → ;an arrow that can be represented on stderr
(right-arrow (current-error-port)))
- (define (upgrade-string names old-version new-version outputs)
- (tabulate (zip (map (lambda (name output)
- (if (string=? output "out")
- name
- (string-append name ":" output)))
- names outputs)
- (map (lambda (old new)
- (if (string=? old new)
- (G_ "(dependencies or package changed)")
- (string-append old " " → " " new)))
- old-version new-version))
- #:initial-indent 3))
-
(let-values (((remove install upgrade downgrade)
(manifest-transaction-effects manifest transaction)))
(match remove
(((($ <manifest-entry> name old-version)
. ($ <manifest-entry> _ new-version output item)) ..1)
(let ((len (length name))
- (downgrade (upgrade-string name old-version new-version
- output)))
+ (downgrade (package-strings name new-version output
+ #:old-versions old-version)))
(if dry-run?
(format (current-error-port)
(N_ "The following package would be downgraded:~%~{~a~%~}~%"
(((($ <manifest-entry> name old-version)
. ($ <manifest-entry> _ new-version output item)) ..1)
(let ((len (length name))
- (upgrade (upgrade-string name
- old-version new-version
- output)))
+ (upgrade (package-strings name new-version output
+ #:old-versions old-version)))
(if dry-run?
(format (current-error-port)
(N_ "The following package would be upgraded:~%~{~a~%~}~%"
zero means that PACKAGE does not match any of REGEXPS."
(relevance package regexps %package-metrics))
-(define (call-with-paginated-output-port proc)
+(define* (call-with-paginated-output-port proc
+ #:key (less-options "FrX"))
(if (isatty?* (current-output-port))
;; Set 'LESS' so that 'less' exits if everything fits on the screen (F),
;; lets ANSI escapes through (r), does not send the termcap
;; initialization string (X). Set it unconditionally because some
;; distros set it to something that doesn't work here.
- (let ((pager (with-environment-variables `(("LESS" "FrX"))
+ ;;
+ ;; For things that produce long lines, such as 'guix processes', use 'R'
+ ;; instead of 'r': this strips hyperlinks but allows 'less' to make a
+ ;; good estimate of the line length.
+ (let ((pager (with-environment-variables `(("LESS" ,less-options))
(open-pipe* OPEN_WRITE
(or (getenv "GUIX_PAGER") (getenv "PAGER")
"less")))))
(lambda () (close-pipe pager))))
(proc (current-output-port))))
-(define-syntax-rule (with-paginated-output-port port exp ...)
- "Evaluate EXP... with PORT bound to a port that talks to the pager if
+(define-syntax with-paginated-output-port
+ (syntax-rules ()
+ "Evaluate EXP... with PORT bound to a port that talks to the pager if
standard output is a tty, or with PORT set to the current output port."
- (call-with-paginated-output-port (lambda (port) exp ...)))
+ ((_ port exp ... #:less-options opts)
+ (call-with-paginated-output-port (lambda (port) exp ...)
+ #:less-options opts))
+ ((_ port exp ...)
+ (call-with-paginated-output-port (lambda (port) exp ...)))))
(define* (display-search-results matches port
#:key
filter-by-duration)
(else
(raise
- (condition (&message
- (message (format #f (G_ "invalid syntax: ~a~%")
- str))))))))
+ (formatted-message (G_ "invalid syntax: ~a~%") str)))))
(define (display-generation profile number)
"Display a one-line summary of generation NUMBER of PROFILE."
(G_ "Try `guix --help' for more information.~%"))
(exit 1))
+;; Representation of a 'guix' command.
+(define-immutable-record-type <command>
+ (command name synopsis category)
+ command?
+ (name command-name)
+ (synopsis command-synopsis)
+ (category command-category))
+
+(define (source-file-command file)
+ "Read FILE, a Scheme source file, and return either a <command> object based
+on the 'define-command' top-level form found therein, or #f if FILE does not
+contain a 'define-command' form."
+ (define command-name
+ (match (string-split file #\/)
+ ((_ ... "guix" "scripts" name)
+ (list (file-sans-extension name)))
+ ((_ ... "guix" "scripts" first second)
+ (list first (file-sans-extension second)))))
+
+ ;; The strategy here is to parse FILE. This is much cheaper than a
+ ;; technique based on run-time introspection where we'd load FILE and all
+ ;; the modules it depends on.
+ (call-with-input-file file
+ (lambda (port)
+ (let loop ()
+ (match (read port)
+ (('define-command _ ('synopsis synopsis)
+ _ ...)
+ (command command-name synopsis 'main))
+ (('define-command _
+ ('category category) ('synopsis synopsis)
+ _ ...)
+ (command command-name synopsis category))
+ ((? eof-object?)
+ #f)
+ (_
+ (loop)))))))
+
(define (command-files)
"Return the list of source files that define Guix sub-commands."
(define directory
(cut string-suffix? ".scm" <>))
(if directory
- (scandir directory dot-scm?)
+ (map (cut string-append directory "/" <>)
+ (scandir directory dot-scm?))
'()))
(define (commands)
- "Return the list of Guix command names."
- (map (compose (cut string-drop-right <> 4)
- basename)
- (command-files)))
+ "Return the list of commands, alphabetically sorted."
+ (filter-map source-file-command (command-files)))
(define (show-guix-help)
(define (internal? command)
(member command '("substitute" "authenticate" "offload"
"perform-download")))
+ (define (display-commands commands)
+ (let* ((names (map (lambda (command)
+ (string-join (command-name command)))
+ commands))
+ (max-width (reduce max 0 (map string-length names))))
+ (for-each (lambda (name command)
+ (format #t " ~a ~a~%"
+ (string-pad-right name max-width)
+ (G_ (command-synopsis command))))
+ names
+ commands)))
+
+ (define (category-predicate category)
+ (lambda (command)
+ (eq? category (command-category command))))
+
(format #t (G_ "Usage: guix COMMAND ARGS...
Run COMMAND with ARGS.\n"))
(newline)
(format #t (G_ "COMMAND must be one of the sub-commands listed below:\n"))
- (newline)
- ;; TODO: Display a synopsis of each command.
- (format #t "~{ ~a~%~}" (sort (remove internal? (commands))
- string<?))
+
+ (let ((commands (commands))
+ (categories (module-ref (resolve-interface '(guix scripts))
+ '%command-categories)))
+ (for-each (match-lambda
+ (('internal . _)
+ #t) ;hide internal commands
+ ((category . synopsis)
+ (format #t "~% ~a~%" (G_ synopsis))
+ (display-commands (filter (category-predicate category)
+ commands))))
+ categories))
(show-bug-report-information))
(define (run-guix-command command . args)
(initialize-guix)
(apply run-guix args))
+;;; Local Variables:
+;;; eval: (put 'guard* 'scheme-indent-function 2)
+;;; End:
+
;;; ui.scm ends here
HCoop / jackhill / guix / guix.git / blobdiff