mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 05:18:07 -05:00
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'.
This commit is contained in:
parent
c6d7e299ae
commit
98eb8cbe8d
8 changed files with 62 additions and 63 deletions
|
@ -19,6 +19,7 @@
|
||||||
|
|
||||||
(define-module (gnu packages)
|
(define-module (gnu packages)
|
||||||
#:use-module (guix packages)
|
#:use-module (guix packages)
|
||||||
|
#:use-module (guix ui)
|
||||||
#:use-module (guix utils)
|
#:use-module (guix utils)
|
||||||
#:use-module (ice-9 ftw)
|
#:use-module (ice-9 ftw)
|
||||||
#:use-module (ice-9 vlist)
|
#:use-module (ice-9 vlist)
|
||||||
|
@ -90,9 +91,8 @@ (define prefix-len
|
||||||
result)
|
result)
|
||||||
(const #f) ; skip
|
(const #f) ; skip
|
||||||
(lambda (path stat errno result)
|
(lambda (path stat errno result)
|
||||||
(format (current-error-port)
|
(warning (_ "cannot access `~a': ~a~%")
|
||||||
(_ "warning: cannot access `~a': ~a~%")
|
path (strerror errno))
|
||||||
path (strerror errno))
|
|
||||||
result)
|
result)
|
||||||
'()
|
'()
|
||||||
%distro-module-directory
|
%distro-module-directory
|
||||||
|
|
|
@ -29,6 +29,7 @@ (define-module (guix gnu-maintenance)
|
||||||
#:use-module (srfi srfi-26)
|
#:use-module (srfi srfi-26)
|
||||||
#:use-module (system foreign)
|
#:use-module (system foreign)
|
||||||
#:use-module (guix ftp-client)
|
#:use-module (guix ftp-client)
|
||||||
|
#:use-module (guix ui)
|
||||||
#:use-module (guix utils)
|
#:use-module (guix utils)
|
||||||
#:use-module (guix packages)
|
#:use-module (guix packages)
|
||||||
#:export (gnu-package-name
|
#:export (gnu-package-name
|
||||||
|
@ -84,12 +85,11 @@ (define (http-fetch uri)
|
||||||
;; (see <http://lists.gnu.org/archive/html/guile-devel/2011-09/msg00089.html>).
|
;; (see <http://lists.gnu.org/archive/html/guile-devel/2011-09/msg00089.html>).
|
||||||
;; Since users may still be using these versions, warn them and
|
;; Since users may still be using these versions, warn them and
|
||||||
;; bail out.
|
;; bail out.
|
||||||
(format (current-error-port)
|
(warning (_ "using Guile ~a, ~a ~s encoding~%")
|
||||||
"warning: using Guile ~a, ~a ~s encoding~%"
|
(version)
|
||||||
(version)
|
"which does not support HTTP"
|
||||||
"which does not support HTTP"
|
(response-transfer-encoding resp))
|
||||||
(response-transfer-encoding resp))
|
(leave (_ "download failed; use a newer Guile~%")
|
||||||
(error "download failed; use a newer Guile"
|
|
||||||
uri resp)))
|
uri resp)))
|
||||||
((string? data) ; old `http-get' returns a string
|
((string? data) ; old `http-get' returns a string
|
||||||
(open-input-string data))
|
(open-input-string data))
|
||||||
|
|
|
@ -43,12 +43,11 @@ (define (derivations-from-package-expressions str system source?)
|
||||||
When SOURCE? is true, return the derivations of the package sources."
|
When SOURCE? is true, return the derivations of the package sources."
|
||||||
(let ((p (read/eval-package-expression str)))
|
(let ((p (read/eval-package-expression str)))
|
||||||
(if source?
|
(if source?
|
||||||
(let ((source (package-source p))
|
(let ((source (package-source p)))
|
||||||
(loc (package-location p)))
|
|
||||||
(if source
|
(if source
|
||||||
(package-source-derivation (%store) source)
|
(package-source-derivation (%store) source)
|
||||||
(leave (_ "~a: error: package `~a' has no source~%")
|
(leave (_ "package `~a' has no source~%")
|
||||||
(location->string loc) (package-name p))))
|
(package-name p))))
|
||||||
(package-derivation (%store) p system))))
|
(package-derivation (%store) p system))))
|
||||||
|
|
||||||
|
|
||||||
|
@ -169,7 +168,9 @@ (define (register-root paths root)
|
||||||
(add-indirect-root (%store) root))
|
(add-indirect-root (%store) root))
|
||||||
((paths ...)
|
((paths ...)
|
||||||
(fold (lambda (path count)
|
(fold (lambda (path count)
|
||||||
(let ((root (string-append root "-" (number->string count))))
|
(let ((root (string-append root
|
||||||
|
"-"
|
||||||
|
(number->string count))))
|
||||||
(symlink path root)
|
(symlink path root)
|
||||||
(add-indirect-root (%store) root))
|
(add-indirect-root (%store) root))
|
||||||
(+ 1 count))
|
(+ 1 count))
|
||||||
|
@ -177,8 +178,7 @@ (define (register-root paths root)
|
||||||
paths))))
|
paths))))
|
||||||
(lambda args
|
(lambda args
|
||||||
(leave (_ "failed to create GC root `~a': ~a~%")
|
(leave (_ "failed to create GC root `~a': ~a~%")
|
||||||
root (strerror (system-error-errno args)))
|
root (strerror (system-error-errno args)))))))
|
||||||
(exit 1)))))
|
|
||||||
|
|
||||||
(define newest-available-packages
|
(define newest-available-packages
|
||||||
(memoize find-newest-available-packages))
|
(memoize find-newest-available-packages))
|
||||||
|
|
|
@ -114,7 +114,7 @@ (define (parse-options)
|
||||||
(store (open-connection))
|
(store (open-connection))
|
||||||
(arg (assq-ref opts 'argument))
|
(arg (assq-ref opts 'argument))
|
||||||
(uri (or (string->uri arg)
|
(uri (or (string->uri arg)
|
||||||
(leave (_ "guix-download: ~a: failed to parse URI~%")
|
(leave (_ "~a: failed to parse URI~%")
|
||||||
arg)))
|
arg)))
|
||||||
(path (case (uri-scheme uri)
|
(path (case (uri-scheme uri)
|
||||||
((file)
|
((file)
|
||||||
|
@ -127,7 +127,7 @@ (define (parse-options)
|
||||||
(basename (uri-path uri))))))
|
(basename (uri-path uri))))))
|
||||||
(hash (call-with-input-file
|
(hash (call-with-input-file
|
||||||
(or path
|
(or path
|
||||||
(leave (_ "guix-download: ~a: download failed~%")
|
(leave (_ "~a: download failed~%")
|
||||||
arg))
|
arg))
|
||||||
(compose sha256 get-bytevector-all)))
|
(compose sha256 get-bytevector-all)))
|
||||||
(fmt (assq-ref opts 'format)))
|
(fmt (assq-ref opts 'format)))
|
||||||
|
|
|
@ -87,9 +87,8 @@ (define unit
|
||||||
("TB" (expt 10 12))
|
("TB" (expt 10 12))
|
||||||
("" 1)
|
("" 1)
|
||||||
(_
|
(_
|
||||||
(leave (_ "error: unknown unit: ~a~%") unit)
|
(leave (_ "unknown unit: ~a~%") unit))))
|
||||||
(exit 1))))
|
(leave (_ "invalid number: ~a~%") numstr))))
|
||||||
(leave (_ "error: invalid number: ~a") numstr))))
|
|
||||||
|
|
||||||
(define %options
|
(define %options
|
||||||
;; Specification of the command-line options.
|
;; Specification of the command-line options.
|
||||||
|
@ -110,7 +109,7 @@ (define %options
|
||||||
(let ((amount (size->number arg)))
|
(let ((amount (size->number arg)))
|
||||||
(if arg
|
(if arg
|
||||||
(alist-cons 'min-freed amount result)
|
(alist-cons 'min-freed amount result)
|
||||||
(leave (_ "error: invalid amount of storage: ~a~%")
|
(leave (_ "invalid amount of storage: ~a~%")
|
||||||
arg))))
|
arg))))
|
||||||
(#f result)))))
|
(#f result)))))
|
||||||
(option '(#\d "delete") #f #f
|
(option '(#\d "delete") #f #f
|
||||||
|
|
|
@ -208,7 +208,7 @@ (define (switch-link)
|
||||||
(switch-symlinks profile previous-profile))
|
(switch-symlinks profile previous-profile))
|
||||||
|
|
||||||
(cond ((not (file-exists? profile)) ; invalid profile
|
(cond ((not (file-exists? profile)) ; invalid profile
|
||||||
(leave (_ "error: profile `~a' does not exist~%")
|
(leave (_ "profile `~a' does not exist~%")
|
||||||
profile))
|
profile))
|
||||||
((zero? number) ; empty profile
|
((zero? number) ; empty profile
|
||||||
(format (current-error-port)
|
(format (current-error-port)
|
||||||
|
@ -477,8 +477,7 @@ (define request name)
|
||||||
(define (ensure-output p sub-drv)
|
(define (ensure-output p sub-drv)
|
||||||
(if (member sub-drv (package-outputs p))
|
(if (member sub-drv (package-outputs p))
|
||||||
p
|
p
|
||||||
(leave (_ "~a: error: package `~a' lacks output `~a'~%")
|
(leave (_ "package `~a' lacks output `~a'~%")
|
||||||
(location->string (package-location p))
|
|
||||||
(package-full-name p)
|
(package-full-name p)
|
||||||
sub-drv)))
|
sub-drv)))
|
||||||
|
|
||||||
|
|
76
guix/ui.scm
76
guix/ui.scm
|
@ -1,6 +1,7 @@
|
||||||
;;; GNU Guix --- Functional package management for GNU
|
;;; GNU Guix --- Functional package management for GNU
|
||||||
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
|
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
|
||||||
;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
|
;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
|
||||||
|
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
|
||||||
;;;
|
;;;
|
||||||
;;; This file is part of GNU Guix.
|
;;; This file is part of GNU Guix.
|
||||||
;;;
|
;;;
|
||||||
|
@ -70,9 +71,8 @@ (define (install-locale)
|
||||||
(lambda _
|
(lambda _
|
||||||
(setlocale LC_ALL ""))
|
(setlocale LC_ALL ""))
|
||||||
(lambda args
|
(lambda args
|
||||||
(format (current-error-port)
|
(warning (_ "failed to install locale: ~a~%")
|
||||||
(_ "warning: failed to install locale: ~a~%")
|
(strerror (system-error-errno args))))))
|
||||||
(strerror (system-error-errno args))))))
|
|
||||||
|
|
||||||
(define (initialize-guix)
|
(define (initialize-guix)
|
||||||
"Perform the usual initialization for stand-alone Guix commands."
|
"Perform the usual initialization for stand-alone Guix commands."
|
||||||
|
@ -81,12 +81,6 @@ (define (initialize-guix)
|
||||||
(setvbuf (current-output-port) _IOLBF)
|
(setvbuf (current-output-port) _IOLBF)
|
||||||
(setvbuf (current-error-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))))
|
(define* (show-version-and-exit #:optional (command (car (command-line))))
|
||||||
"Display version information for COMMAND and `(exit 0)'."
|
"Display version information for COMMAND and `(exit 0)'."
|
||||||
(simple-format #t "~a (~a) ~a~%"
|
(simple-format #t "~a (~a) ~a~%"
|
||||||
|
@ -111,16 +105,16 @@ (define (call-with-error-handling thunk)
|
||||||
(file (location-file location))
|
(file (location-file location))
|
||||||
(line (location-line location))
|
(line (location-line location))
|
||||||
(column (location-column 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
|
file line column
|
||||||
(package-full-name package) input)))
|
(package-full-name package) input)))
|
||||||
((nix-connection-error? c)
|
((nix-connection-error? c)
|
||||||
(leave (_ "error: failed to connect to `~a': ~a~%")
|
(leave (_ "failed to connect to `~a': ~a~%")
|
||||||
(nix-connection-error-file c)
|
(nix-connection-error-file c)
|
||||||
(strerror (nix-connection-error-code c))))
|
(strerror (nix-connection-error-code c))))
|
||||||
((nix-protocol-error? c)
|
((nix-protocol-error? c)
|
||||||
;; FIXME: Server-provided error messages aren't i18n'd.
|
;; FIXME: Server-provided error messages aren't i18n'd.
|
||||||
(leave (_ "error: build failed: ~a~%")
|
(leave (_ "build failed: ~a~%")
|
||||||
(nix-protocol-error-message c))))
|
(nix-protocol-error-message c))))
|
||||||
(thunk)))
|
(thunk)))
|
||||||
|
|
||||||
|
@ -375,35 +369,41 @@ (define program-name
|
||||||
(define guix-warning-port
|
(define guix-warning-port
|
||||||
(make-parameter (current-warning-port)))
|
(make-parameter (current-warning-port)))
|
||||||
|
|
||||||
(define-syntax warning
|
(define-syntax-rule (define-diagnostic name prefix)
|
||||||
(lambda (s)
|
"Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all
|
||||||
"Emit a warming. The macro assumes that `_' is bound to `gettext'."
|
messages."
|
||||||
;; All this just to preserve `-Wformat' warnings. Too much?
|
(define-syntax name
|
||||||
|
(lambda (x)
|
||||||
|
(define (augmented-format-string fmt)
|
||||||
|
(string-append "~:[~*~;guix ~a: ~]~a" (syntax->datum fmt)))
|
||||||
|
|
||||||
(define (augmented-format-string fmt)
|
(syntax-case x (N_ _) ; these are literals, yeah...
|
||||||
(string-append "~:[~*~;guix ~a: ~]~a" (syntax->datum fmt)))
|
((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
|
(define-diagnostic warning "warning: ") ; emit a warning
|
||||||
#'(_ "warning: "))
|
|
||||||
|
|
||||||
(syntax-case s (N_ _) ; these are literals, yeah...
|
(define-diagnostic report-error "error: ")
|
||||||
((warning (_ fmt) args ...)
|
(define-syntax-rule (leave args ...)
|
||||||
(string? (syntax->datum #'fmt))
|
"Emit an error message and exit."
|
||||||
(with-syntax ((fmt* (augmented-format-string #'fmt))
|
(begin
|
||||||
(prefix prefix))
|
(report-error args ...)
|
||||||
#'(format (guix-warning-port) (gettext fmt*)
|
(exit 1)))
|
||||||
(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 (guix-main arg0 . args)
|
(define (guix-main arg0 . args)
|
||||||
(initialize-guix)
|
(initialize-guix)
|
||||||
|
|
|
@ -9,4 +9,5 @@ guix/scripts/download.scm
|
||||||
guix/scripts/package.scm
|
guix/scripts/package.scm
|
||||||
guix/scripts/gc.scm
|
guix/scripts/gc.scm
|
||||||
guix/scripts/pull.scm
|
guix/scripts/pull.scm
|
||||||
|
guix/gnu-maintenance.scm
|
||||||
guix/ui.scm
|
guix/ui.scm
|
||||||
|
|
Loading…
Reference in a new issue