;;; 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)
(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))
+
+ ((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))
- ((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
((message-condition? c)
;; Normally '&message' error conditions have an i18n'd message.
- (leave (G_ "~a~%")
- (gettext (condition-message c) %gettext-domain))))
+ (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
(('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)
HCoop / jackhill / guix / guix.git / blobdiff