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.

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