From a2011be5dfaf2b94a1d0e3dfbcf4b512389b4711 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 11 Apr 2013 22:30:06 +0200 Subject: 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. --- guix/scripts/build.scm | 16 ++++++---------- guix/scripts/download.scm | 3 +-- guix/scripts/gc.scm | 15 ++++----------- guix/scripts/package.scm | 20 ++++++++----------- guix/ui.scm | 49 +++++++++++++++++++++++++++++++++++++++++++---- 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 -- cgit v1.2.3