ui: Add a `warning' macro.
* guix/ui.scm (program-name, guix-warning-port): New variables. (warning): New macro. (guix-main): Parametrize PROGRAM-NAME. * guix/scripts/build.scm, guix/scripts/download.scm, guix/scripts/gc.scm, guix/scripts/package.scm: Adjust to use `leave' and `warning' consistently.
This commit is contained in:
parent
53c63ee937
commit
a2011be5df
|
@ -176,9 +176,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
|
||||||
0
|
0
|
||||||
paths))))
|
paths))))
|
||||||
(lambda args
|
(lambda args
|
||||||
(format (current-error-port)
|
(leave (_ "failed to create GC root `~a': ~a~%")
|
||||||
(_ "failed to create GC root `~a': ~a~%")
|
root (strerror (system-error-errno args)))
|
||||||
root (strerror (system-error-errno args)))
|
|
||||||
(exit 1)))))
|
(exit 1)))))
|
||||||
|
|
||||||
(define newest-available-packages
|
(define newest-available-packages
|
||||||
|
@ -202,13 +201,10 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
|
||||||
((p) ; one match
|
((p) ; one match
|
||||||
p)
|
p)
|
||||||
((p x ...) ; several matches
|
((p x ...) ; several matches
|
||||||
(format (current-error-port)
|
(warning (_ "ambiguous package specification `~a'~%") request)
|
||||||
(_ "warning: ambiguous package specification `~a'~%")
|
(warning (_ "choosing ~a from ~a~%")
|
||||||
request)
|
(package-full-name p)
|
||||||
(format (current-error-port)
|
(location->string (package-location p)))
|
||||||
(_ "warning: choosing ~a from ~a~%")
|
|
||||||
(package-full-name p)
|
|
||||||
(location->string (package-location p)))
|
|
||||||
p)
|
p)
|
||||||
(_ ; no matches
|
(_ ; no matches
|
||||||
(if version
|
(if version
|
||||||
|
|
|
@ -81,8 +81,7 @@ and the hash of its contents.\n"))
|
||||||
((or "base16" "hex" "hexadecimal")
|
((or "base16" "hex" "hexadecimal")
|
||||||
bytevector->base16-string)
|
bytevector->base16-string)
|
||||||
(x
|
(x
|
||||||
(format (current-error-port)
|
(leave (_ "unsupported hash format: ~a~%") arg))))
|
||||||
"unsupported hash format: ~a~%" arg))))
|
|
||||||
|
|
||||||
(alist-cons 'format fmt-proc
|
(alist-cons 'format fmt-proc
|
||||||
(alist-delete 'format result))))
|
(alist-delete 'format result))))
|
||||||
|
|
|
@ -87,13 +87,9 @@ interpreted."
|
||||||
("TB" (expt 10 12))
|
("TB" (expt 10 12))
|
||||||
("" 1)
|
("" 1)
|
||||||
(_
|
(_
|
||||||
(format (current-error-port) (_ "error: unknown unit: ~a~%")
|
(leave (_ "error: unknown unit: ~a~%") unit)
|
||||||
unit)
|
|
||||||
(exit 1))))
|
(exit 1))))
|
||||||
(begin
|
(leave (_ "error: invalid number: ~a") numstr))))
|
||||||
(format (current-error-port)
|
|
||||||
(_ "error: invalid number: ~a") numstr)
|
|
||||||
(exit 1)))))
|
|
||||||
|
|
||||||
(define %options
|
(define %options
|
||||||
;; Specification of the command-line options.
|
;; Specification of the command-line options.
|
||||||
|
@ -114,11 +110,8 @@ 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)
|
||||||
(begin
|
(leave (_ "error: invalid amount of storage: ~a~%")
|
||||||
(format (current-error-port)
|
arg))))
|
||||||
(_ "error: invalid amount of storage: ~a~%")
|
|
||||||
arg)
|
|
||||||
(exit 1)))))
|
|
||||||
(#f result)))))
|
(#f result)))))
|
||||||
(option '(#\d "delete") #f #f
|
(option '(#\d "delete") #f #f
|
||||||
(lambda (opt name arg result)
|
(lambda (opt name arg result)
|
||||||
|
|
|
@ -208,12 +208,10 @@ 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
|
||||||
(format (current-error-port)
|
(leave (_ "error: profile `~a' does not exist~%")
|
||||||
(_ "error: profile `~a' does not exist~%")
|
profile))
|
||||||
profile))
|
|
||||||
((zero? number) ; empty profile
|
((zero? number) ; empty profile
|
||||||
(format (current-error-port)
|
(leave (_ "nothing to do: already at the empty profile~%")))
|
||||||
(_ "nothing to do: already at the empty profile~%")))
|
|
||||||
((or (zero? previous-number) ; going to emptiness
|
((or (zero? previous-number) ; going to emptiness
|
||||||
(not (file-exists? previous-profile)))
|
(not (file-exists? previous-profile)))
|
||||||
(let*-values (((drv-path drv)
|
(let*-values (((drv-path drv)
|
||||||
|
@ -465,13 +463,11 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
|
||||||
(list name (package-version p) sub-drv (ensure-output p sub-drv)
|
(list name (package-version p) sub-drv (ensure-output p sub-drv)
|
||||||
(package-transitive-propagated-inputs p)))
|
(package-transitive-propagated-inputs p)))
|
||||||
((p p* ...)
|
((p p* ...)
|
||||||
(format (current-error-port)
|
(warning (_ "ambiguous package specification `~a'~%")
|
||||||
(_ "warning: ambiguous package specification `~a'~%")
|
request)
|
||||||
request)
|
(warning (_ "choosing ~a from ~a~%")
|
||||||
(format (current-error-port)
|
(package-full-name p)
|
||||||
(_ "warning: choosing ~a from ~a~%")
|
(location->string (package-location p)))
|
||||||
(package-full-name p)
|
|
||||||
(location->string (package-location p)))
|
|
||||||
(list name (package-version p) sub-drv (ensure-output p sub-drv)
|
(list name (package-version p) sub-drv (ensure-output p sub-drv)
|
||||||
(package-transitive-propagated-inputs p)))
|
(package-transitive-propagated-inputs p)))
|
||||||
(()
|
(()
|
||||||
|
|
49
guix/ui.scm
49
guix/ui.scm
|
@ -47,6 +47,9 @@
|
||||||
string->recutils
|
string->recutils
|
||||||
package->recutils
|
package->recutils
|
||||||
run-guix-command
|
run-guix-command
|
||||||
|
program-name
|
||||||
|
guix-warning-port
|
||||||
|
warning
|
||||||
guix-main))
|
guix-main))
|
||||||
|
|
||||||
;;; Commentary:
|
;;; Commentary:
|
||||||
|
@ -332,6 +335,43 @@ WIDTH columns."
|
||||||
(symbol-append 'guix- command))))
|
(symbol-append 'guix- command))))
|
||||||
(apply command-main args)))
|
(apply command-main args)))
|
||||||
|
|
||||||
|
(define program-name
|
||||||
|
;; Name of the command-line program currently executing, or #f.
|
||||||
|
(make-parameter #f))
|
||||||
|
|
||||||
|
(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 (guix-main arg0 . args)
|
(define (guix-main arg0 . args)
|
||||||
(initialize-guix)
|
(initialize-guix)
|
||||||
(let ()
|
(let ()
|
||||||
|
@ -340,10 +380,11 @@ WIDTH columns."
|
||||||
(() (show-guix-usage) (exit 1))
|
(() (show-guix-usage) (exit 1))
|
||||||
(("--help") (show-guix-usage))
|
(("--help") (show-guix-usage))
|
||||||
(("--version") (show-version-and-exit "guix"))
|
(("--version") (show-version-and-exit "guix"))
|
||||||
(((? option? arg1) args ...) (show-guix-usage) (exit 1))
|
(((? option?) args ...) (show-guix-usage) (exit 1))
|
||||||
((command args ...)
|
((command args ...)
|
||||||
(apply run-guix-command
|
(parameterize ((program-name command))
|
||||||
(string->symbol command)
|
(apply run-guix-command
|
||||||
args)))))
|
(string->symbol command)
|
||||||
|
args))))))
|
||||||
|
|
||||||
;;; ui.scm ends here
|
;;; ui.scm ends here
|
||||||
|
|
Loading…
Reference in New Issue