diff --git a/gnu/packages.scm b/gnu/packages.scm index f4d93a789d..e9f2540b91 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -19,6 +19,7 @@ (define-module (gnu packages) #:use-module (guix packages) + #:use-module (guix ui) #:use-module (guix utils) #:use-module (ice-9 ftw) #:use-module (ice-9 vlist) @@ -90,9 +91,8 @@ (define prefix-len result) (const #f) ; skip (lambda (path stat errno result) - (format (current-error-port) - (_ "warning: cannot access `~a': ~a~%") - path (strerror errno)) + (warning (_ "cannot access `~a': ~a~%") + path (strerror errno)) result) '() %distro-module-directory diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 89e7f25589..0dc2fab092 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -29,6 +29,7 @@ (define-module (guix gnu-maintenance) #:use-module (srfi srfi-26) #:use-module (system foreign) #:use-module (guix ftp-client) + #:use-module (guix ui) #:use-module (guix utils) #:use-module (guix packages) #:export (gnu-package-name @@ -84,12 +85,11 @@ (define (http-fetch uri) ;; (see ). ;; Since users may still be using these versions, warn them and ;; bail out. - (format (current-error-port) - "warning: using Guile ~a, ~a ~s encoding~%" - (version) - "which does not support HTTP" - (response-transfer-encoding resp)) - (error "download failed; use a newer Guile" + (warning (_ "using Guile ~a, ~a ~s encoding~%") + (version) + "which does not support HTTP" + (response-transfer-encoding resp)) + (leave (_ "download failed; use a newer Guile~%") uri resp))) ((string? data) ; old `http-get' returns a string (open-input-string data)) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index f296f3031f..0bf154dd41 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -43,12 +43,11 @@ (define (derivations-from-package-expressions str system source?) When SOURCE? is true, return the derivations of the package sources." (let ((p (read/eval-package-expression str))) (if source? - (let ((source (package-source p)) - (loc (package-location p))) + (let ((source (package-source p))) (if source (package-source-derivation (%store) source) - (leave (_ "~a: error: package `~a' has no source~%") - (location->string loc) (package-name p)))) + (leave (_ "package `~a' has no source~%") + (package-name p)))) (package-derivation (%store) p system)))) @@ -169,7 +168,9 @@ (define (register-root paths root) (add-indirect-root (%store) root)) ((paths ...) (fold (lambda (path count) - (let ((root (string-append root "-" (number->string count)))) + (let ((root (string-append root + "-" + (number->string count)))) (symlink path root) (add-indirect-root (%store) root)) (+ 1 count)) @@ -177,8 +178,7 @@ (define (register-root paths root) paths)))) (lambda args (leave (_ "failed to create GC root `~a': ~a~%") - root (strerror (system-error-errno args))) - (exit 1))))) + root (strerror (system-error-errno args))))))) (define newest-available-packages (memoize find-newest-available-packages)) diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 7c00312c74..c5c56c5054 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -114,7 +114,7 @@ (define (parse-options) (store (open-connection)) (arg (assq-ref opts 'argument)) (uri (or (string->uri arg) - (leave (_ "guix-download: ~a: failed to parse URI~%") + (leave (_ "~a: failed to parse URI~%") arg))) (path (case (uri-scheme uri) ((file) @@ -127,7 +127,7 @@ (define (parse-options) (basename (uri-path uri)))))) (hash (call-with-input-file (or path - (leave (_ "guix-download: ~a: download failed~%") + (leave (_ "~a: download failed~%") arg)) (compose sha256 get-bytevector-all))) (fmt (assq-ref opts 'format))) diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 3d918923f8..7625bc46e6 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -87,9 +87,8 @@ (define unit ("TB" (expt 10 12)) ("" 1) (_ - (leave (_ "error: unknown unit: ~a~%") unit) - (exit 1)))) - (leave (_ "error: invalid number: ~a") numstr)))) + (leave (_ "unknown unit: ~a~%") unit)))) + (leave (_ "invalid number: ~a~%") numstr)))) (define %options ;; Specification of the command-line options. @@ -110,7 +109,7 @@ (define %options (let ((amount (size->number arg))) (if arg (alist-cons 'min-freed amount result) - (leave (_ "error: invalid amount of storage: ~a~%") + (leave (_ "invalid amount of storage: ~a~%") arg)))) (#f result))))) (option '(#\d "delete") #f #f diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 4295abaf57..c5656efc14 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -208,7 +208,7 @@ (define (switch-link) (switch-symlinks profile previous-profile)) (cond ((not (file-exists? profile)) ; invalid profile - (leave (_ "error: profile `~a' does not exist~%") + (leave (_ "profile `~a' does not exist~%") profile)) ((zero? number) ; empty profile (format (current-error-port) @@ -477,8 +477,7 @@ (define request name) (define (ensure-output p sub-drv) (if (member sub-drv (package-outputs p)) p - (leave (_ "~a: error: package `~a' lacks output `~a'~%") - (location->string (package-location p)) + (leave (_ "package `~a' lacks output `~a'~%") (package-full-name p) sub-drv))) diff --git a/guix/ui.scm b/guix/ui.scm index 938b5d259c..e42c331ed6 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013 Ludovic Courtès ;;; Copyright © 2013 Mark H Weaver +;;; Copyright © 2013 Nikita Karetnikov ;;; ;;; This file is part of GNU Guix. ;;; @@ -70,9 +71,8 @@ (define (install-locale) (lambda _ (setlocale LC_ALL "")) (lambda args - (format (current-error-port) - (_ "warning: failed to install locale: ~a~%") - (strerror (system-error-errno args)))))) + (warning (_ "failed to install locale: ~a~%") + (strerror (system-error-errno args)))))) (define (initialize-guix) "Perform the usual initialization for stand-alone Guix commands." @@ -81,12 +81,6 @@ (define (initialize-guix) (setvbuf (current-output-port) _IOLBF) (setvbuf (current-error-port) _IOLBF)) -(define-syntax-rule (leave fmt args ...) - "Format FMT and ARGS to the error port and exit." - (begin - (format (current-error-port) fmt args ...) - (exit 1))) - (define* (show-version-and-exit #:optional (command (car (command-line)))) "Display version information for COMMAND and `(exit 0)'." (simple-format #t "~a (~a) ~a~%" @@ -111,16 +105,16 @@ (define (call-with-error-handling thunk) (file (location-file location)) (line (location-line location)) (column (location-column location))) - (leave (_ "~a:~a:~a: error: package `~a' has an invalid input: ~s~%") + (leave (_ "~a:~a:~a: package `~a' has an invalid input: ~s~%") file line column (package-full-name package) input))) ((nix-connection-error? c) - (leave (_ "error: failed to connect to `~a': ~a~%") + (leave (_ "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 (_ "error: build failed: ~a~%") + (leave (_ "build failed: ~a~%") (nix-protocol-error-message c)))) (thunk))) @@ -375,35 +369,41 @@ (define program-name (define guix-warning-port (make-parameter (current-warning-port))) -(define-syntax warning - (lambda (s) - "Emit a warming. The macro assumes that `_' is bound to `gettext'." - ;; All this just to preserve `-Wformat' warnings. Too much? +(define-syntax-rule (define-diagnostic name prefix) + "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all +messages." + (define-syntax name + (lambda (x) + (define (augmented-format-string fmt) + (string-append "~:[~*~;guix ~a: ~]~a" (syntax->datum fmt))) - (define (augmented-format-string fmt) - (string-append "~:[~*~;guix ~a: ~]~a" (syntax->datum fmt))) + (syntax-case x (N_ _) ; these are literals, yeah... + ((name (_ fmt) args (... ...)) + (string? (syntax->datum #'fmt)) + (with-syntax ((fmt* (augmented-format-string #'fmt)) + (prefix (datum->syntax x prefix))) + #'(format (guix-warning-port) (gettext fmt*) + (program-name) (program-name) prefix + args (... ...)))) + ((name (N_ singular plural n) args (... ...)) + (and (string? (syntax->datum #'singular)) + (string? (syntax->datum #'plural))) + (with-syntax ((s (augmented-format-string #'singular)) + (p (augmented-format-string #'plural)) + (prefix (datum->syntax x prefix))) + #'(format (guix-warning-port) + (ngettext s p n %gettext-domain) + (program-name) (program-name) prefix + args (... ...)))))))) - (define prefix - #'(_ "warning: ")) +(define-diagnostic warning "warning: ") ; emit a warning - (syntax-case s (N_ _) ; these are literals, yeah... - ((warning (_ fmt) args ...) - (string? (syntax->datum #'fmt)) - (with-syntax ((fmt* (augmented-format-string #'fmt)) - (prefix prefix)) - #'(format (guix-warning-port) (gettext fmt*) - (program-name) (program-name) prefix - args ...))) - ((warning (N_ singular plural n) args ...) - (and (string? (syntax->datum #'singular)) - (string? (syntax->datum #'plural))) - (with-syntax ((s (augmented-format-string #'singular)) - (p (augmented-format-string #'plural)) - (b prefix)) - #'(format (guix-warning-port) - (ngettext s p n %gettext-domain) - (program-name) (program-name) b - args ...)))))) +(define-diagnostic report-error "error: ") +(define-syntax-rule (leave args ...) + "Emit an error message and exit." + (begin + (report-error args ...) + (exit 1))) (define (guix-main arg0 . args) (initialize-guix) diff --git a/po/POTFILES.in b/po/POTFILES.in index bdb894db20..528e7a6aa7 100644 --- a/po/POTFILES.in +++ b/po/POTFILES.in @@ -9,4 +9,5 @@ guix/scripts/download.scm guix/scripts/package.scm guix/scripts/gc.scm guix/scripts/pull.scm +guix/gnu-maintenance.scm guix/ui.scm