[PATCH] ui: Add a 'define-diagnostic' macro. (was: Enhanced 'warning')

[Nikita Karetnikov <nikita@karetnikov.org>]

[-- Attachment #1.1: Type: text/plain, Size: 1020 bytes --]

> This is a macro-generating macro.  In the body of the generated macro,
> above, there are 4 occurrences of ‘...’.  But these ellipses have no
> meaning in the outer macro; they are just meaningful in the context of
> the generated macro, hence the error.

> Instead, you should replace all 4 occurrences with (... ...).

> Yes, it’s always surprising at first.  ;-)

Yep, could you add it to the manual?  There is only a reference to this
book [1] which briefly discusses the topic.

I'm attaching the patch that adds a 'define-diagnostic' macro.  Can I
push it to 'master'?

I ran 'grep' to find things which use "warning" or "leave."  I guess
it's possible to change other functions (the ones that use 'error' and
'format').  But it will probably trigger a rebuild.  So what should I
do?

Also, is it possible to move 'report-error' inside 'leave'?

Finally, I haven't tested each change.  All tests pass and there are no
warnings.  Is it good enough?

[1] http://scheme.com/tspl4/


[-- Attachment #1.2: 0001-ui-Add-a-define-diagnostic-macro.patch --]
[-- Type: text/x-diff, Size: 14218 bytes --]

From 9f5d9501a270bd64c563e41f57278aba42266364 Mon Sep 17 00:00:00 2001
From: Nikita Karetnikov <nikita@karetnikov.org>
Date: Fri, 19 Apr 2013 19:17:41 +0000
Subject: [PATCH] ui: Add a 'define-diagnostic' macro.

* guix/ui.scm (define-diagnostic): New macro, which is based on the
  previous version of 'warning'.
  (warning, leave): Redefine using 'define-diagnostic'.
  (report-error): New macro.
  (install-locale): Use 'warning' instead of 'format'.
  (call-with-error-handling): Adjust 'leave'.
* gnu/packages.scm (package-files): Use 'warning' instead of 'format'.
* guix/gnu-maintenance.scm (http-fetch): Use 'warning' and 'leave'.
* guix/scripts/build.scm (derivations-from-package-expressions, guix-build):
  Adjust 'leave'.
* guix/scripts/download.scm (guix-download): Adjust 'leave'.
* guix/scripts/gc.scm (size->number, %options): Adjust 'leave'.
* guix/scripts/package.scm (roll-back, guix-package): Adjust 'leave'.
---
 gnu/packages.scm          |    6 ++--
 guix/gnu-maintenance.scm  |   12 +++---
 guix/scripts/build.scm    |   14 ++++----
 guix/scripts/download.scm |    4 +-
 guix/scripts/gc.scm       |    7 ++--
 guix/scripts/package.scm  |    5 +--
 guix/ui.scm               |   82 ++++++++++++++++++++++----------------------
 7 files changed, 64 insertions(+), 66 deletions(-)

diff --git a/gnu/packages.scm b/gnu/packages.scm
index f4d93a7..e9f2540 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 @@
                       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 89e7f25..5df9c6f 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -29,6 +29,7 @@
   #: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 @@
                 ;; (see <http://lists.gnu.org/archive/html/guile-devel/2011-09/msg00089.html>).
                 ;; 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 f296f30..0bf154d 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -43,12 +43,11 @@
 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))))
 
 \f
@@ -169,7 +168,9 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
             (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 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
                   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 7c00312..c5c56c5 100644
--- a/guix/scripts/download.scm
+++ b/guix/scripts/download.scm
@@ -114,7 +114,7 @@ and the hash of its contents.\n"))
            (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 @@ and the hash of its contents.\n"))
                                       (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 3d91892..f464579 100644
--- a/guix/scripts/gc.scm
+++ b/guix/scripts/gc.scm
@@ -87,9 +87,8 @@ interpreted."
              ("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 @@ interpreted."
                       (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 4295aba..c5656ef 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -208,7 +208,7 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
       (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 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
     (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 938b5d2..e42c331 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 <ludo@gnu.org>
 ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -70,9 +71,8 @@
     (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 @@
   (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 @@ General help using GNU software: <http://www.gnu.org/gethelp/>"))
                     (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 @@ WIDTH columns."
 (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-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)))
+
+      (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-diagnostic warning "warning: ") ; emit a warning
+
+(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)
-- 
1.7.5.4


[-- Attachment #2: Type: application/pgp-signature, Size: 835 bytes --]