;;; Copyright © 2019 Chris Marusich <cmmarusich@gmail.com>
;;; 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)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:use-module (ice-9 regex)
+ #:autoload (ice-9 popen) (open-pipe* close-pipe)
#:autoload (system base compile) (compile-file)
#:autoload (system repl repl) (start-repl)
#:autoload (system repl debug) (make-debug stack->vector)
string->number*
size->number
show-derivation-outputs
+ build-notifier
show-what-to-build
show-what-to-build*
show-manifest-transaction
read/eval
read/eval-package-expression
check-available-space
+ indented-string
fill-paragraph
%text-width
texi->plain-text
file-hyperlink
location->hyperlink
+ with-paginated-output-port
relevance
package-relevance
display-search-results
;; Give 'load' an absolute file name so that it doesn't try to
;; search for FILE in %LOAD-PATH. Note: use 'load', not
- ;; 'primitive-load', so that FILE is compiled, which then allows us
- ;; to provide better error reporting with source line numbers.
+ ;; 'primitive-load', so that FILE is compiled, which then allows
+ ;; us to provide better error reporting with source line numbers.
(load (canonicalize-path file)))
(const #f))))))
(lambda _
(('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)
\"1MiB\", to a number of bytes. Raise an error if STR could not be
interpreted."
(define unit-pos
- (string-rindex str char-set:digit))
+ (string-rindex str
+ (char-set-union (char-set #\.) char-set:digit)))
(define unit
(and unit-pos (substring str (+ 1 unit-pos))))
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' come 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 when EPIPE errors are caught and lead to 'exit'
+ "Run EXP... in a context where EPIPE errors are caught and lead to 'exit'
with successful exit code. This is useful when writing to the standard output
may lead to EPIPE, because the standard output is piped through 'head' or
similar."
(('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 #t if there's something to build, #f otherwise. When USE-SUBSTITUTES?,
-check and report what is prerequisites are available for download."
+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. 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))
drv))
(define substitutable-info
- ;; Call 'substitutation-oracle' upfront so we don't end up launching the
+ ;; Call 'substitution-oracle' upfront so we don't end up launching the
;; substituter many times. This makes a big difference, especially when
;; DRV is a long list as is the case with 'guix environment'.
(if use-substitutes?
colorize-store-file-name
identity))
- (let*-values (((build download)
+ (let*-values (((build/full download)
(derivation-build-plan store inputs
#:mode mode
#:substitutable-info
#:hook ,hook
#:build ,(cons file build))))))))
'(#:graft () #:hook () #:build ())
- build)
+ build/full)
((#:graft graft #:hook hook #:build build)
(values graft hook build)))))
(define installed-size
;; 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)
- (pair? build)))
+ (values (pair? build/full) (pair? download))))
(define show-what-to-build*
(store-lift show-what-to-build))
+(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
+any build happening."
+ (define not-comma
+ (char-set-complement (char-set #\,)))
+
+ (define (read-derivation-from-file* item)
+ (catch 'system-error
+ (lambda ()
+ (read-derivation-from-file item))
+ (const #f)))
+
+ (lambda (continue store things mode)
+ (define inputs
+ ;; List of derivation inputs to build. Filter out non-existent '.drv'
+ ;; files because the daemon transparently tries to substitute them.
+ (filter-map (match-lambda
+ (((? derivation-path? drv) . output)
+ (let ((drv (read-derivation-from-file* drv))
+ (outputs (string-tokenize output not-comma)))
+ (and drv (derivation-input drv outputs))))
+ ((? derivation-path? drv)
+ (and=> (read-derivation-from-file* drv)
+ derivation-input))
+ (_
+ #f))
+ things))
+
+ (let-values (((build? download?)
+ (show-what-to-build store inputs
+ #:dry-run? dry-run?
+ #:use-substitutes? use-substitutes?
+ #:verbosity verbosity
+ #:mode mode)))
+
+ (unless (and (or build? download?)
+ dry-run?)
+ (continue #t)))))
+
(define (right-arrow port)
"Return either a string containing the 'RIGHT ARROW' character, or an ASCII
replacement if PORT is not Unicode-capable."
(lambda (key . args)
"->"))))
+(define* (tabulate rows #:key (initial-indent 0) (max-width 25)
+ (inter-column " "))
+ "Return a list of strings where each string is a tabulated representation of
+an element of ROWS. All the ROWS must be lists of the same number of cells.
+
+Add INITIAL-INDENT white space at the beginning of each row. Ensure that
+columns are at most MAX-WIDTH characters wide. Use INTER-COLUMN as a
+separator between subsequent columns."
+ (define column-widths
+ ;; List of column widths.
+ (let loop ((rows rows)
+ (widths '()))
+ (match rows
+ (((? null?) ...)
+ (reverse widths))
+ (((column rest ...) ...)
+ (loop rest
+ (cons (min (apply max (map string-length column))
+ max-width)
+ widths))))))
+
+ (define indent
+ (make-string initial-indent #\space))
+
+ (define (string-pad-right* str len)
+ (if (> (string-length str) len)
+ str
+ (string-pad-right str len)))
+
+ (map (lambda (row)
+ (string-trim-right
+ (string-append indent
+ (string-join
+ (map string-pad-right* row column-widths)
+ inter-column))))
+ rows))
+
(define* (show-manifest-transaction store manifest transaction
#:key dry-run?)
"Display what will/would be installed/removed from MANIFEST by TRANSACTION."
- (define (package-strings name version output item)
- (map (lambda (name version output item)
- (format #f " ~a~:[:~a~;~*~]\t~a\t~a"
- name
- (equal? output "out") output version
- (if (package? item)
- (package-output store item output)
- item)))
- name version output item))
+ (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 name old-version new-version output item)
- (format #f " ~a~:[:~a~;~*~]\t~a ~a ~a\t~a"
- name (equal? output "out") output
- old-version → new-version
- (if (package? item)
- (package-output store item output)
- item)))
-
(let-values (((remove install upgrade downgrade)
(manifest-transaction-effects manifest transaction)))
(match remove
((($ <manifest-entry> name version output item) ..1)
(let ((len (length name))
- (remove (package-strings name version output item)))
+ (remove (package-strings name version output)))
(if dry-run?
(format (current-error-port)
(N_ "The following package would be removed:~%~{~a~%~}~%"
(((($ <manifest-entry> name old-version)
. ($ <manifest-entry> _ new-version output item)) ..1)
(let ((len (length name))
- (downgrade (map upgrade-string
- name old-version new-version output item)))
+ (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 (map upgrade-string
- name old-version new-version output item)))
+ (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~%~}~%"
(match install
((($ <manifest-entry> name version output item _) ..1)
(let ((len (length name))
- (install (package-strings name version output item)))
+ (install (package-strings name version output)))
(if dry-run?
(format (current-error-port)
(N_ "The following package would be installed:~%~{~a~%~}~%"
(lambda ()
body ...)))))
+(define* (indented-string str indent
+ #:key (initial-indent? #t))
+ "Return STR with each newline preceded by INDENT spaces. When
+INITIAL-INDENT? is true, the first line is also indented."
+ (define indent-string
+ (make-list indent #\space))
+
+ (list->string
+ (string-fold-right (lambda (chr result)
+ (if (eqv? chr #\newline)
+ (cons chr (append indent-string result))
+ (cons chr result)))
+ '()
+ (if initial-indent?
+ (string-append (list->string indent-string) str)
+ str))))
+
(define* (fill-paragraph str width #:optional (column 0))
"Fill STR such that each line contains at most WIDTH characters, assuming
that the first character is at COLUMN.
;;;
(define %text-width
- (make-parameter (terminal-columns)))
-
-(set! (@@ (texinfo plain-text) wrap*)
- ;; XXX: Monkey patch this private procedure to let 'package->recutils'
- ;; parameterize the fill of description field correctly.
- (lambda strings
- (let ((indent (fluid-ref (@@ (texinfo plain-text) *indent*))))
- (fill-string (string-concatenate strings)
- #:line-width (%text-width) #:initial-indent indent
- #:subsequent-indent indent))))
+ ;; '*line-width*' was introduced in Guile 2.2.7/3.0.1. On older versions of
+ ;; Guile, monkey-patch 'wrap*' below.
+ (if (defined? '*line-width*)
+ (let ((parameter (fluid->parameter *line-width*)))
+ (parameter (terminal-columns))
+ parameter)
+ (make-parameter (terminal-columns))))
+
+(unless (defined? '*line-width*) ;Guile < 2.2.7
+ (set! (@@ (texinfo plain-text) wrap*)
+ ;; XXX: Monkey patch this private procedure to let 'package->recutils'
+ ;; parameterize the fill of description field correctly.
+ (lambda strings
+ (let ((indent (fluid-ref (@@ (texinfo plain-text) *indent*))))
+ (fill-string (string-concatenate strings)
+ #:line-width (%text-width) #:initial-indent indent
+ #:subsequent-indent indent)))))
(define (texi->plain-text str)
"Return a plain-text representation of texinfo fragment STR."
(string-map (match-lambda
(#\newline #\space)
(chr chr))
- (or (and=> (package-synopsis-string p) P_)
- "")))
+ (or (package-synopsis-string p) "")))
(format port "~a~%"
(string->recutils
(string-trim-right
(parameterize ((%text-width width*))
+ ;; Call 'texi->plain-text' on the concatenated string to account
+ ;; for the width of "description:" in paragraph filling.
(texi->plain-text
(string-append "description: "
(or (and=> (package-description p) P_)
(+ relevance (* weight (apply + (map score-regexp lst)))))))))
0 metrics)))
- (let ((scores (map regexp->score regexps)))
- ;; Return zero if one of REGEXPS doesn't match.
- (if (any zero? scores)
- 0
- (reduce + 0 scores))))
+ (let loop ((regexps regexps)
+ (total-score 0))
+ (match regexps
+ ((head . tail)
+ (let ((score (regexp->score head)))
+ ;; Return zero if one of PATTERNS doesn't match.
+ (if (zero? score)
+ 0
+ (loop tail (+ total-score score)))))
+ (() total-score))))
(define %package-metrics
;; Metrics used to compute the "relevance score" of a package against a set
(,(lambda (package)
(filter (lambda (output)
(not (member output
- ;; Some common outpus shared by many packages.
+ ;; Some common outputs shared by many packages.
'("out" "doc" "debug" "lib" "include" "bin"))))
(package-outputs package)))
. 1)
zero means that PACKAGE does not match any of REGEXPS."
(relevance package regexps %package-metrics))
+(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.
+ ;;
+ ;; 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")))))
+ (dynamic-wind
+ (const #t)
+ (lambda () (proc pager))
+ (lambda () (close-pipe pager))))
+ (proc (current-output-port))))
+
+(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."
+ ((_ 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
(command "guix search")
(define (line-count str)
(string-count str #\newline))
- (let loop ((matches matches))
- (match matches
- (((package . score) rest ...)
- (let* ((links? (supports-hyperlinks? port))
- (text (call-with-output-string
- (lambda (port)
- (print package port
- #:hyperlinks? links?
- #:extra-fields
- `((relevance . ,score)))))))
- (if (and max-rows
- (> (port-line port) first-line) ;print at least one result
- (> (+ 4 (line-count text) (port-line port))
- max-rows))
- (unless (null? rest)
- (display-hint (format #f (G_ "Run @code{~a ... | less} \
-to view all the results.")
- command)))
- (begin
- (display text port)
- (loop rest)))))
- (()
- #t))))
+ (with-paginated-output-port paginated
+ (let loop ((matches matches))
+ (match matches
+ (((package . score) rest ...)
+ (let* ((links? (supports-hyperlinks? port)))
+ (print package paginated
+ #:hyperlinks? links?
+ #:extra-fields `((relevance . ,score)))
+ (loop rest)))
+ (()
+ #t)))))
\f
(define (string->generations str)
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)
(define (run-guix . args)
"Run the 'guix' command defined by command line ARGS.
Unlike 'guix-main', this procedure assumes that locale, i18n support,
-and signal handling has already been set up."
+and signal handling have already been set up."
(define option? (cut string-prefix? "-" <>))
;; The default %LOAD-EXTENSIONS includes the empty string, which doubles the
(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