From 9f5d9501a270bd64c563e41f57278aba42266364 Mon Sep 17 00:00:00 2001 From: Nikita Karetnikov 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 ). ;; 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)))) @@ -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 ;;; Copyright © 2013 Mark H Weaver +;;; Copyright © 2013 Nikita Karetnikov ;;; ;;; 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: ")) (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