aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2013-04-11 22:30:06 +0200
committerLudovic Courtès <ludo@gnu.org>2013-04-11 22:30:06 +0200
commita2011be5dfaf2b94a1d0e3dfbcf4b512389b4711 (patch)
tree5e1745f40400c87bd23d641ef31dc460ca3693c2
parent53c63ee93790e4e4054bf6547199d3490b78bf47 (diff)
downloadguix-a2011be5dfaf2b94a1d0e3dfbcf4b512389b4711.tar.gz
guix-a2011be5dfaf2b94a1d0e3dfbcf4b512389b4711.zip
ui: Add a `warning' macro.
* guix/ui.scm (program-name, guix-warning-port): New variables. (warning): New macro. (guix-main): Parametrize PROGRAM-NAME. * guix/scripts/build.scm, guix/scripts/download.scm, guix/scripts/gc.scm, guix/scripts/package.scm: Adjust to use `leave' and `warning' consistently.
-rw-r--r--guix/scripts/build.scm16
-rw-r--r--guix/scripts/download.scm3
-rw-r--r--guix/scripts/gc.scm15
-rw-r--r--guix/scripts/package.scm20
-rw-r--r--guix/ui.scm49
5 files changed, 64 insertions, 39 deletions
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index a49bfdbeb8..339ad0d06f 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -176,9 +176,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
0
paths))))
(lambda args
- (format (current-error-port)
- (_ "failed to create GC root `~a': ~a~%")
- root (strerror (system-error-errno args)))
+ (leave (_ "failed to create GC root `~a': ~a~%")
+ root (strerror (system-error-errno args)))
(exit 1)))))
(define newest-available-packages
@@ -202,13 +201,10 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
((p) ; one match
p)
((p x ...) ; several matches
- (format (current-error-port)
- (_ "warning: ambiguous package specification `~a'~%")
- request)
- (format (current-error-port)
- (_ "warning: choosing ~a from ~a~%")
- (package-full-name p)
- (location->string (package-location p)))
+ (warning (_ "ambiguous package specification `~a'~%") request)
+ (warning (_ "choosing ~a from ~a~%")
+ (package-full-name p)
+ (location->string (package-location p)))
p)
(_ ; no matches
(if version
diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm
index 3f989a3494..7c00312c74 100644
--- a/guix/scripts/download.scm
+++ b/guix/scripts/download.scm
@@ -81,8 +81,7 @@ and the hash of its contents.\n"))
((or "base16" "hex" "hexadecimal")
bytevector->base16-string)
(x
- (format (current-error-port)
- "unsupported hash format: ~a~%" arg))))
+ (leave (_ "unsupported hash format: ~a~%") arg))))
(alist-cons 'format fmt-proc
(alist-delete 'format result))))
diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm
index 12d80fd171..3d918923f8 100644
--- a/guix/scripts/gc.scm
+++ b/guix/scripts/gc.scm
@@ -87,13 +87,9 @@ interpreted."
("TB" (expt 10 12))
("" 1)
(_
- (format (current-error-port) (_ "error: unknown unit: ~a~%")
- unit)
+ (leave (_ "error: unknown unit: ~a~%") unit)
(exit 1))))
- (begin
- (format (current-error-port)
- (_ "error: invalid number: ~a") numstr)
- (exit 1)))))
+ (leave (_ "error: invalid number: ~a") numstr))))
(define %options
;; Specification of the command-line options.
@@ -114,11 +110,8 @@ interpreted."
(let ((amount (size->number arg)))
(if arg
(alist-cons 'min-freed amount result)
- (begin
- (format (current-error-port)
- (_ "error: invalid amount of storage: ~a~%")
- arg)
- (exit 1)))))
+ (leave (_ "error: invalid amount of storage: ~a~%")
+ arg))))
(#f result)))))
(option '(#\d "delete") #f #f
(lambda (opt name arg result)
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 6de2f1beb6..89708ccc49 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -208,12 +208,10 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
(switch-symlinks profile previous-profile))
(cond ((not (file-exists? profile)) ; invalid profile
- (format (current-error-port)
- (_ "error: profile `~a' does not exist~%")
- profile))
+ (leave (_ "error: profile `~a' does not exist~%")
+ profile))
((zero? number) ; empty profile
- (format (current-error-port)
- (_ "nothing to do: already at the empty profile~%")))
+ (leave (_ "nothing to do: already at the empty profile~%")))
((or (zero? previous-number) ; going to emptiness
(not (file-exists? previous-profile)))
(let*-values (((drv-path drv)
@@ -465,13 +463,11 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
(list name (package-version p) sub-drv (ensure-output p sub-drv)
(package-transitive-propagated-inputs p)))
((p p* ...)
- (format (current-error-port)
- (_ "warning: ambiguous package specification `~a'~%")
- request)
- (format (current-error-port)
- (_ "warning: choosing ~a from ~a~%")
- (package-full-name p)
- (location->string (package-location p)))
+ (warning (_ "ambiguous package specification `~a'~%")
+ request)
+ (warning (_ "choosing ~a from ~a~%")
+ (package-full-name p)
+ (location->string (package-location p)))
(list name (package-version p) sub-drv (ensure-output p sub-drv)
(package-transitive-propagated-inputs p)))
(()
diff --git a/guix/ui.scm b/guix/ui.scm
index 94f0825a0a..dfb6418a10 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -47,6 +47,9 @@
string->recutils
package->recutils
run-guix-command
+ program-name
+ guix-warning-port
+ warning
guix-main))
;;; Commentary:
@@ -332,6 +335,43 @@ WIDTH columns."
(symbol-append 'guix- command))))
(apply command-main args)))
+(define program-name
+ ;; Name of the command-line program currently executing, or #f.
+ (make-parameter #f))
+
+(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 (augmented-format-string fmt)
+ (string-append "~:[~;guix ~a: ~]~a" (syntax->datum fmt)))
+
+ (define prefix
+ #'(_ "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 (guix-main arg0 . args)
(initialize-guix)
(let ()
@@ -340,10 +380,11 @@ WIDTH columns."
(() (show-guix-usage) (exit 1))
(("--help") (show-guix-usage))
(("--version") (show-version-and-exit "guix"))
- (((? option? arg1) args ...) (show-guix-usage) (exit 1))
+ (((? option?) args ...) (show-guix-usage) (exit 1))
((command args ...)
- (apply run-guix-command
- (string->symbol command)
- args)))))
+ (parameterize ((program-name command))
+ (apply run-guix-command
+ (string->symbol command)
+ args))))))
;;; ui.scm ends here