diff options
Diffstat (limited to 'guix/ui.scm')
| -rw-r--r-- | guix/ui.scm | 159 |
1 files changed, 114 insertions, 45 deletions
diff --git a/guix/ui.scm b/guix/ui.scm index efc3f39186..ecaf975c1f 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -15,6 +15,7 @@ ;;; 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. ;;; @@ -60,6 +61,7 @@ ;; 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) @@ -494,7 +496,11 @@ guix package -i glibc-utf8-locales 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." @@ -541,8 +547,9 @@ There is NO WARRANTY, to the extent permitted by law. 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) @@ -1068,16 +1075,19 @@ summary, and level 0 shows nothing." (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. - (G_ "~:[~,1h MB would be downloaded~%~;~]") + (highlight (G_ "~:[~,1h MB would be downloaded~%~;~]")) (null? download) download-size) (format (current-error-port) - (N_ "~:[~h item would be downloaded~%~;~]" - "~:[~h items would be downloaded~%~;~]" - (length download)) + (highlight + (N_ "~:[~h item would be downloaded~%~;~]" + "~:[~h items would be downloaded~%~;~]" + (length download))) (null? download) (length download)))))) (begin @@ -1116,16 +1126,19 @@ summary, and level 0 shows nothing." (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. - (G_ "~:[~,1h MB will be downloaded~%~;~]") + (highlight (G_ "~:[~,1h MB will be downloaded~%~;~]")) (null? download) download-size) (format (current-error-port) - (N_ "~:[~h item will be downloaded~%~;~]" - "~:[~h items will be downloaded~%~;~]" - (length download)) + (highlight + (N_ "~:[~h item will be downloaded~%~;~]" + "~:[~h items will be downloaded~%~;~]" + (length download))) (null? download) (length download))))))) (check-available-space installed-size) @@ -1232,31 +1245,27 @@ separator between subsequent columns." (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 @@ -1279,8 +1288,8 @@ separator between subsequent columns." (((($ <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~%~}~%" @@ -1297,9 +1306,8 @@ separator between subsequent columns." (((($ <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~%~}~%" @@ -1988,6 +1996,44 @@ optionally contain a version number and an output name, as in these examples: (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 @@ -1999,28 +2045,51 @@ optionally contain a version number and an output name, as in these examples: (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) |