From: Nikita Karetnikov <nikita@karetnikov.org>
To: "Ludovic Courtès" <ludo@gnu.org>
Cc: bug-guix@gnu.org
Subject: [PATCH] ui: Add a 'define-diagnostic' macro. (was: Enhanced 'warning')
Date: Sat, 20 Apr 2013 00:16:32 +0400 [thread overview]
Message-ID: <8761zie0nz.fsf_-_@karetnikov.org> (raw)
In-Reply-To: <87r4i7wo53.fsf@gnu.org> ("Ludovic Courtès"'s message of "Thu, 18 Apr 2013 22:59:52 +0200")
[-- 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 --]
next prev parent reply other threads:[~2013-04-19 20:14 UTC|newest]
Thread overview: 28+ messages / expand[flat|nested] mbox.gz Atom feed top
2013-04-01 5:06 [PATCH] Add 'guix hash' Nikita Karetnikov
2013-04-03 8:34 ` Ludovic Courtès
2013-04-05 14:04 ` Nikita Karetnikov
2013-04-05 14:14 ` Nikita Karetnikov
2013-04-05 16:15 ` Ludovic Courtès
2013-04-10 11:48 ` Nikita Karetnikov
2013-04-10 11:54 ` Ludovic Courtès
2013-04-10 12:21 ` Nikita Karetnikov
2013-04-10 17:30 ` Ludovic Courtès
2013-04-05 16:13 ` Ludovic Courtès
2013-04-09 16:28 ` Nikita Karetnikov
2013-04-11 20:35 ` Ludovic Courtès
2013-04-12 5:24 ` master: FAIL: tests/guix-package.sh (was: [PATCH] Add 'guix hash'.) Nikita Karetnikov
2013-04-12 6:48 ` master: FAIL: tests/guix-package.sh Nikita Karetnikov
2013-04-12 16:24 ` Ludovic Courtès
2013-04-18 5:01 ` Enhanced 'warning' (was: [PATCH] Add 'guix hash'.) Nikita Karetnikov
2013-04-18 5:06 ` Enhanced 'warning' Nikita Karetnikov
2013-04-18 11:55 ` Ludovic Courtès
2013-04-18 19:27 ` Nikita Karetnikov
2013-04-18 20:59 ` Ludovic Courtès
2013-04-19 20:16 ` Nikita Karetnikov [this message]
2013-04-20 5:48 ` [PATCH] ui: Add a 'define-diagnostic' macro Nikita Karetnikov
2013-04-20 9:10 ` Ludovic Courtès
2013-04-20 17:33 ` Nikita Karetnikov
2013-04-20 19:55 ` Ludovic Courtès
2013-04-20 9:09 ` Ludovic Courtès
2013-04-21 18:14 ` [PATCH] Add 'guix hash' Nikita Karetnikov
2013-04-21 19:02 ` Ludovic Courtès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=8761zie0nz.fsf_-_@karetnikov.org \
--to=nikita@karetnikov.org \
--cc=bug-guix@gnu.org \
--cc=ludo@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.