aboutsummaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/gnu-maintenance.scm12
-rw-r--r--guix/scripts/build.scm14
-rw-r--r--guix/scripts/download.scm4
-rw-r--r--guix/scripts/gc.scm7
-rw-r--r--guix/scripts/package.scm5
-rw-r--r--guix/ui.scm82
6 files changed, 61 insertions, 63 deletions
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 89e7f25589..0dc2fab092 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 f296f3031f..0bf154dd41 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 7c00312c74..c5c56c5054 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 3d918923f8..7625bc46e6 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 4295abaf57..c5656efc14 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 938b5d259c..e42c331ed6 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)
generated by cgit v1.2.3 (git 2.45.0) at 2024-12-22 03:40:13 +0000