kreyren/guix-kreyren
1
0
Fork 0
Code Issues 1 Pull Requests 1 Releases Activity

ui: Add a 'define-diagnostic' macro.

Browse Source 
* 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) (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 @@
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

12
guix/gnu-maintenance.scm
View File

@ -29,6 +29,7 @@
#: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 @@
;; (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))

14
guix/scripts/build.scm
View File

@ -43,12 +43,11 @@
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 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(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 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
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))

4
guix/scripts/download.scm
View File

@ -114,7 +114,7 @@ and the hash of its contents.\n"))
(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 @@ and the hash of its contents.\n"))
(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)))

7
guix/scripts/gc.scm
View File

@ -87,9 +87,8 @@ interpreted."
("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 @@ interpreted."
(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

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)) (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 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
(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
View File

@ -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 @@
(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 @@
(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 @@ General help using GNU software: <http://www.gnu.org/gethelp/>"))
(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 @@ WIDTH columns."
(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)

1
po/POTFILES.in
View File

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