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'. * po/POTFILES.in: Add 'guix/gnu-maintenance.scm'.master
parent
c6d7e299ae
commit
98eb8cbe8d
|
@ -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
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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)))
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)))
|
||||
|
||||
|
|
76
guix/ui.scm
76
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-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)))
|
||||
|
||||
(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 prefix
|
||||
#'(_ "warning: "))
|
||||
(define-diagnostic warning "warning: ") ; emit a 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-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)
|
||||
|
|
|
@ -9,4 +9,5 @@ guix/scripts/download.scm
|
|||
guix/scripts/package.scm
|
||||
guix/scripts/gc.scm
|
||||
guix/scripts/pull.scm
|
||||
guix/gnu-maintenance.scm
|
||||
guix/ui.scm
|
||||
|
|
Reference in New Issue