rekahsoft
/
guix
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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:
Nikita Karetnikov 2013-04-21 08:08:40 +00:00
parent c6d7e299ae
commit 98eb8cbe8d
8 changed files with 62 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
gnu/packages.scm
View File

@ -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

12
guix/gnu-maintenance.scm
View File

@ -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))

14
guix/scripts/build.scm
View File

@ -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))

4
guix/scripts/download.scm
View File

@ -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)))

7
guix/scripts/gc.scm
View File

@ -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

5
guix/scripts/package.scm
View File

@ -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
View File

@ -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)

1
po/POTFILES.in
View File

@ -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