Browse Source

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.
version-0.8.3
Ludovic Courtès 9 years ago
parent
commit
a2011be5df
  1. 16
      guix/scripts/build.scm
  2. 3
      guix/scripts/download.scm
  3. 15
      guix/scripts/gc.scm
  4. 20
      guix/scripts/package.scm
  5. 49
      guix/ui.scm

16
guix/scripts/build.scm

@ -176,9 +176,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
0
paths))))
(lambda args
(format (current-error-port)
(_ "failed to create GC root `~a': ~a~%")
root (strerror (system-error-errno args)))
(leave (_ "failed to create GC root `~a': ~a~%")
root (strerror (system-error-errno args)))
(exit 1)))))
(define newest-available-packages
@ -202,13 +201,10 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
((p) ; one match
p)
((p x ...) ; several matches
(format (current-error-port)
(_ "warning: ambiguous package specification `~a'~%")
request)
(format (current-error-port)
(_ "warning: choosing ~a from ~a~%")
(package-full-name p)
(location->string (package-location p)))
(warning (_ "ambiguous package specification `~a'~%") request)
(warning (_ "choosing ~a from ~a~%")
(package-full-name p)
(location->string (package-location p)))
p)
(_ ; no matches
(if version

3
guix/scripts/download.scm

@ -81,8 +81,7 @@ and the hash of its contents.\n"))
((or "base16" "hex" "hexadecimal")
bytevector->base16-string)
(x
(format (current-error-port)
"unsupported hash format: ~a~%" arg))))
(leave (_ "unsupported hash format: ~a~%") arg))))
(alist-cons 'format fmt-proc
(alist-delete 'format result))))

15
guix/scripts/gc.scm

@ -87,13 +87,9 @@ interpreted."
("TB" (expt 10 12))
("" 1)
(_
(format (current-error-port) (_ "error: unknown unit: ~a~%")
unit)
(leave (_ "error: unknown unit: ~a~%") unit)
(exit 1))))
(begin
(format (current-error-port)
(_ "error: invalid number: ~a") numstr)
(exit 1)))))
(leave (_ "error: invalid number: ~a") numstr))))
(define %options
;; Specification of the command-line options.
@ -114,11 +110,8 @@ interpreted."
(let ((amount (size->number arg)))
(if arg
(alist-cons 'min-freed amount result)
(begin
(format (current-error-port)
(_ "error: invalid amount of storage: ~a~%")
arg)
(exit 1)))))
(leave (_ "error: invalid amount of storage: ~a~%")
arg))))
(#f result)))))
(option '(#\d "delete") #f #f
(lambda (opt name arg result)

20
guix/scripts/package.scm

@ -208,12 +208,10 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
(switch-symlinks profile previous-profile))
(cond ((not (file-exists? profile)) ; invalid profile
(format (current-error-port)
(_ "error: profile `~a' does not exist~%")
profile))
(leave (_ "error: profile `~a' does not exist~%")
profile))
((zero? number) ; empty profile
(format (current-error-port)
(_ "nothing to do: already at the empty profile~%")))
(leave (_ "nothing to do: already at the empty profile~%")))
((or (zero? previous-number) ; going to emptiness
(not (file-exists? previous-profile)))
(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)
(package-transitive-propagated-inputs p)))
((p p* ...)
(format (current-error-port)
(_ "warning: ambiguous package specification `~a'~%")
request)
(format (current-error-port)
(_ "warning: choosing ~a from ~a~%")
(package-full-name p)
(location->string (package-location p)))
(warning (_ "ambiguous package specification `~a'~%")
request)
(warning (_ "choosing ~a from ~a~%")
(package-full-name p)
(location->string (package-location p)))
(list name (package-version p) sub-drv (ensure-output p sub-drv)
(package-transitive-propagated-inputs p)))
(()

49
guix/ui.scm

@ -47,6 +47,9 @@
string->recutils
package->recutils
run-guix-command
program-name
guix-warning-port
warning
guix-main))
;;; Commentary:
@ -332,6 +335,43 @@ WIDTH columns."
(symbol-append 'guix- command))))
(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)
(initialize-guix)
(let ()
@ -340,10 +380,11 @@ WIDTH columns."
(() (show-guix-usage) (exit 1))
(("--help") (show-guix-usage))
(("--version") (show-version-and-exit "guix"))
(((? option? arg1) args ...) (show-guix-usage) (exit 1))
(((? option?) args ...) (show-guix-usage) (exit 1))
((command args ...)
(apply run-guix-command
(string->symbol command)
args)))))
(parameterize ((program-name command))
(apply run-guix-command
(string->symbol command)
args))))))
;;; ui.scm ends here

Loading…
Cancel
Save