diff options
Diffstat (limited to 'guix/ui.scm')
| -rw-r--r-- | guix/ui.scm | 142 |
1 files changed, 84 insertions, 58 deletions
diff --git a/guix/ui.scm b/guix/ui.scm index 345bf490b2..9e0fa26d19 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -26,6 +26,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix ui) + #:use-module (guix gexp) #:use-module (guix utils) #:use-module (guix store) #:use-module (guix config) @@ -54,7 +55,7 @@ #:use-module (texinfo) #:use-module (texinfo plain-text) #:use-module (texinfo string-utils) - #:export (_ + #:export (G_ N_ P_ report-error @@ -116,7 +117,7 @@ ;; Text domain for package synopses and descriptions. "guix-packages") -(define _ (cut gettext <> %gettext-domain)) +(define G_ (cut gettext <> %gettext-domain)) (define N_ (cut ngettext <> <> <> %gettext-domain)) (define (P_ msgid) @@ -139,7 +140,7 @@ messages." (syntax-case x () ((name (underscore fmt) args (... ...)) (and (string? (syntax->datum #'fmt)) - (free-identifier=? #'underscore #'_)) + (free-identifier=? #'underscore #'G_)) (with-syntax ((fmt* (augmented-format-string #'fmt)) (prefix (datum->syntax x prefix))) #'(format (guix-warning-port) (gettext fmt*) @@ -237,7 +238,7 @@ messages." (case on-error ((debug) (newline) - (display (_ "entering debugger; type ',bt' for a backtrace\n")) + (display (G_ "entering debugger; type ',bt' for a backtrace\n")) (start-repl #:debug (make-debug (stack->vector stack) 0 (error-string frame args) #f))) @@ -253,15 +254,19 @@ ARGS is the list of arguments received by the 'throw' handler." (match args (('system-error . rest) (let ((err (system-error-errno args))) - (report-error (_ "failed to load '~a': ~a~%") file (strerror err)))) + (report-error (G_ "failed to load '~a': ~a~%") file (strerror err)))) (('syntax-error proc message properties form . rest) (let ((loc (source-properties->location properties))) - (format (current-error-port) (_ "~a: error: ~a~%") + (format (current-error-port) (G_ "~a: error: ~a~%") (location->string loc) message))) (('srfi-34 obj) - (report-error (_ "exception thrown: ~s~%") obj)) + (if (message-condition? obj) + (report-error (G_ "~a~%") + (gettext (condition-message obj) + %gettext-domain)) + (report-error (G_ "exception thrown: ~s~%") obj))) ((error args ...) - (report-error (_ "failed to load '~a':~%") file) + (report-error (G_ "failed to load '~a':~%") file) (apply display-error frame (current-error-port) args)))) (define (warn-about-load-error file args) ;FIXME: factorize with ↑ @@ -270,16 +275,20 @@ exiting. ARGS is the list of arguments received by the 'throw' handler." (match args (('system-error . rest) (let ((err (system-error-errno args))) - (warning (_ "failed to load '~a': ~a~%") file (strerror err)))) + (warning (G_ "failed to load '~a': ~a~%") file (strerror err)))) (('syntax-error proc message properties form . rest) (let ((loc (source-properties->location properties))) - (format (current-error-port) (_ "~a: warning: ~a~%") + (format (current-error-port) (G_ "~a: warning: ~a~%") (location->string loc) message))) (('srfi-34 obj) - (warning (_ "failed to load '~a': exception thrown: ~s~%") - file 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))) ((error args ...) - (warning (_ "failed to load '~a':~%") file) + (warning (G_ "failed to load '~a':~%") file) (apply display-error #f (current-error-port) args)))) (define (install-locale) @@ -288,11 +297,18 @@ exiting. ARGS is the list of arguments received by the 'throw' handler." (lambda _ (setlocale LC_ALL "")) (lambda args - (warning (_ "failed to install locale: ~a~%") + (warning (G_ "failed to install locale: ~a~%") (strerror (system-error-errno args)))))) (define (initialize-guix) "Perform the usual initialization for stand-alone Guix commands." + ;; By default don't annoy users with deprecation warnings. In practice, + ;; 'define-deprecated' in (ice-9 deprecated) arranges so that those warnings + ;; are emitted at expansion-time only, but there are cases where they could + ;; slip through, for instance when interpreting code. + (unless (getenv "GUILE_WARN_DEPRECATED") + (debug-disable 'warn-deprecated)) + (install-locale) (textdomain %gettext-domain) @@ -311,9 +327,9 @@ exiting. ARGS is the list of arguments received by the 'throw' handler." ;; TRANSLATORS: Translate "(C)" to the copyright symbol ;; (C-in-a-circle), if this symbol is available in the user's ;; locale. Otherwise, do not translate "(C)"; leave it as-is. */ - (_ "(C)") - (_ "the Guix authors\n")) - (display (_"\ + (G_ "(C)") + (G_ "the Guix authors\n")) + (display (G_"\ License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html> This is free software: you are free to change and redistribute it. There is NO WARRANTY, to the extent permitted by law. @@ -325,11 +341,11 @@ There is NO WARRANTY, to the extent permitted by law. ;; package. Please add another line saying "Report translation bugs to ;; ...\n" with the address for translation bugs (typically your translation ;; team's web or email address). - (format #t (_ " + (format #t (G_ " Report bugs to: ~a.") %guix-bug-report-address) - (format #t (_ " + (format #t (G_ " ~a home page: <~a>") %guix-package-name %guix-home-page-url) - (display (_ " + (display (G_ " General help using GNU software: <http://www.gnu.org/gethelp/>")) (newline)) @@ -374,13 +390,13 @@ nicely." (lambda () (apply make-regexp regexp flags)) (lambda (key proc message . rest) - (leave (_ "'~a' is not a valid regular expression: ~a~%") + (leave (G_ "'~a' is not a valid regular expression: ~a~%") regexp message)))) (define (string->number* str) "Like `string->number', but error out with an error message on failure." (or (string->number str) - (leave (_ "~a: invalid number~%") str))) + (leave (G_ "~a: invalid number~%") str))) (define (size->number str) "Convert STR, a storage measurement representation such as \"1024\" or @@ -397,7 +413,7 @@ interpreted." str)) (num (string->number numstr))) (unless num - (leave (_ "invalid number: ~a~%") numstr)) + (leave (G_ "invalid number: ~a~%") numstr)) ((compose inexact->exact round) (* num @@ -420,7 +436,7 @@ interpreted." ("YB" (expt 10 24)) ("" 1) (x - (leave (_ "unknown unit: ~a~%") unit))))))) + (leave (G_ "unknown unit: ~a~%") unit))))))) (define (call-with-error-handling thunk) "Call THUNK within a user-friendly error handler." @@ -437,58 +453,62 @@ interpreted." (file (location-file location)) (line (location-line location)) (column (location-column location))) - (leave (_ "~a:~a:~a: package `~a' has an invalid input: ~s~%") + (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 (_ "~a: ~a: build system `~a' does not support cross builds~%") + (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 (_ "profile '~a' does not exist~%") + (leave (G_ "profile '~a' does not exist~%") (profile-error-profile c))) ((missing-generation-error? c) - (leave (_ "generation ~a of profile '~a' does not exist~%") + (leave (G_ "generation ~a of profile '~a' does not exist~%") (missing-generation-error-generation c) (profile-error-profile c))) ((nar-error? c) (let ((file (nar-error-file c)) (port (nar-error-port c))) (if file - (leave (_ "corrupt input while restoring '~a' from ~s~%") + (leave (G_ "corrupt input while restoring '~a' from ~s~%") file (or (port-filename* port) port)) - (leave (_ "corrupt input while restoring archive from ~s~%") + (leave (G_ "corrupt input while restoring archive from ~s~%") (or (port-filename* port) port))))) ((nix-connection-error? c) - (leave (_ "failed to connect to `~a': ~a~%") + (leave (G_ "failed to connect to `~a': ~a~%") (nix-connection-error-file c) (strerror (nix-connection-error-code c)))) ((nix-protocol-error? c) ;; FIXME: Server-provided error messages aren't i18n'd. - (leave (_ "build failed: ~a~%") + (leave (G_ "build failed: ~a~%") (nix-protocol-error-message c))) ((derivation-missing-output-error? c) - (leave (_ "reference to invalid output '~a' of derivation '~a'~%") + (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 (_ "file '~a' could not be found in these \ + (leave (G_ "file '~a' could not be found in these \ directories:~{ ~a~}~%") (file-search-error-file-name c) (file-search-error-search-path c))) ((message-condition? c) ;; Normally '&message' error conditions have an i18n'd message. - (leave (_ "~a~%") + (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 (_ "~a: ~a~%") proc + (leave (G_ "~a: ~a~%") proc (apply format #f format-string format-args)))))) (define-syntax-rule (leave-on-EPIPE exp ...) @@ -523,18 +543,22 @@ similar." (lambda () (call-with-input-string str read)) (lambda args - (leave (_ "failed to read expression ~s: ~s~%") + (leave (G_ "failed to read expression ~s: ~s~%") str args))))) (catch #t (lambda () (eval exp (force %guix-user-module))) (lambda args - (report-error (_ "failed to evaluate expression '~a':~%") exp) + (report-error (G_ "failed to evaluate expression '~a':~%") exp) (match args (('syntax-error proc message properties form . rest) - (report-error (_ "syntax error: ~a~%") message)) + (report-error (G_ "syntax error: ~a~%") message)) (('srfi-34 obj) - (report-error (_ "exception thrown: ~s~%") obj)) + (if (message-condition? obj) + (report-error (G_ "~a~%") + (gettext (condition-message obj) + %gettext-domain)) + (report-error (G_ "exception thrown: ~s~%") obj))) ((error args ...) (apply display-error #f (current-error-port) args)) (what? #f)) @@ -546,7 +570,7 @@ error." (match (read/eval str) ((? package? p) p) (x - (leave (_ "expression ~s does not evaluate to a package~%") + (leave (G_ "expression ~s does not evaluate to a package~%") str)))) (define (show-derivation-outputs derivation) @@ -754,13 +778,13 @@ replacement if PORT is not Unicode-capable." (define (location->string loc) "Return a human-friendly, GNU-standard representation of LOC." (match loc - (#f (_ "<unknown location>")) + (#f (G_ "<unknown location>")) (($ <location> file line column) (format #f "~a:~a:~a" file line column)))) -(define (config-directory) +(define* (config-directory #:key (ensure? #t)) "Return the name of the configuration directory, after making sure that it -exists. Honor the XDG specs, +exists if ENSURE? is true. Honor the XDG specs, <http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html>." (let ((dir (and=> (or (getenv "XDG_CONFIG_HOME") (and=> (getenv "HOME") @@ -768,12 +792,13 @@ exists. Honor the XDG specs, (cut string-append <> "/guix")))) (catch 'system-error (lambda () - (mkdir-p dir) + (when ensure? + (mkdir-p dir)) dir) (lambda args (let ((err (system-error-errno args))) ;; ERR is necessarily different from EEXIST. - (leave (_ "failed to create configuration directory `~a': ~a~%") + (leave (G_ "failed to create configuration directory `~a': ~a~%") dir (strerror err))))))) (define* (fill-paragraph str width #:optional (column 0)) @@ -904,7 +929,7 @@ WIDTH columns." (dependencies->recutils (filter package? inputs))))) (format port "location: ~a~%" (or (and=> (package-location p) location->string) - (_ "unknown"))) + (G_ "unknown"))) ;; Note: Starting from version 1.6 or recutils, hyphens are not allowed in ;; field identifiers. @@ -918,7 +943,7 @@ WIDTH columns." ((? license? license) (license-name license)) (x - (_ "unknown")))) + (G_ "unknown")))) (format port "synopsis: ~a~%" (string-map (match-lambda (#\newline #\space) @@ -991,6 +1016,7 @@ following patterns: \"1d\", \"1w\", \"1m\"." (make-time time-duration 0 (string->number (match:substring match 1))))) ((string-match "^([0-9]+)h$" str) + => (lambda (match) (hours->duration 1 match))) ((string-match "^([0-9]+)d$" str) @@ -1076,7 +1102,7 @@ DURATION-RELATION with the current time." (define (display-generation profile number) "Display a one-line summary of generation NUMBER of PROFILE." (unless (zero? number) - (let ((header (format #f (_ "Generation ~a\t~a") number + (let ((header (format #f (G_ "Generation ~a\t~a") number (date->string (time-utc->date (generation-time profile number)) @@ -1086,7 +1112,7 @@ DURATION-RELATION with the current time." ;; TRANSLATORS: The word "current" here is an adjective for ;; "Generation", as in "current generation". Use the appropriate ;; gender where applicable. - (format #t (_ "~a\t(current)~%") header) + (format #t (G_ "~a\t(current)~%") header) (format #t "~a~%" header))))) (define (display-profile-content-diff profile gen1 gen2) @@ -1129,7 +1155,7 @@ way." (profile-manifest (generation-file-name profile number)))))) (define (display-generation-change previous current) - (format #t (_ "switched from generation ~a to ~a~%") previous current)) + (format #t (G_ "switched from generation ~a to ~a~%") previous current)) (define (roll-back* store profile) "Like 'roll-back', but display what is happening." @@ -1145,7 +1171,7 @@ way." (define (delete-generation* store profile generation) "Like 'delete-generation', but display what is going on." - (format #t (_ "deleting ~a~%") + (format #t (G_ "deleting ~a~%") (generation-file-name profile generation)) (delete-generation store profile generation)) @@ -1176,7 +1202,7 @@ optionally contain a version number and an output name, as in these examples: (define (show-guix-usage) (format (current-error-port) - (_ "Try `guix --help' for more information.~%")) + (G_ "Try `guix --help' for more information.~%")) (exit 1)) (define (command-files) @@ -1204,10 +1230,10 @@ optionally contain a version number and an output name, as in these examples: (member command '("substitute" "authenticate" "offload" "perform-download"))) - (format #t (_ "Usage: guix COMMAND ARGS... + (format #t (G_ "Usage: guix COMMAND ARGS... Run COMMAND with ARGS.\n")) (newline) - (format #t (_ "COMMAND must be one of the sub-commands listed below:\n")) + (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)) @@ -1227,7 +1253,7 @@ found." (resolve-interface `(guix scripts ,command))) (lambda - (format (current-error-port) - (_ "guix: ~a: command not found~%") command) + (G_ "guix: ~a: command not found~%") command) (show-guix-usage)))) (let ((command-main (module-ref module @@ -1246,7 +1272,7 @@ and signal handling has already been set up." (match args (() (format (current-error-port) - (_ "guix: missing command name~%")) + (G_ "guix: missing command name~%")) (show-guix-usage)) ((or ("-h") ("--help")) (show-guix-help)) @@ -1254,7 +1280,7 @@ and signal handling has already been set up." (show-version-and-exit "guix")) (((? option? o) args ...) (format (current-error-port) - (_ "guix: unrecognized option '~a'~%") o) + (G_ "guix: unrecognized option '~a'~%") o) (show-guix-usage)) (("help" command) (apply run-guix-command (string->symbol command) |