summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/build/ruby-build-system.scm53
-rw-r--r--guix/git.scm8
-rw-r--r--guix/gnu-maintenance.scm3
-rw-r--r--guix/inferior.scm26
-rw-r--r--guix/scripts/archive.scm2
-rw-r--r--guix/scripts/build.scm2
-rw-r--r--guix/scripts/copy.scm2
-rw-r--r--guix/scripts/environment.scm55
-rw-r--r--guix/scripts/pack.scm6
-rw-r--r--guix/scripts/package.scm3
-rw-r--r--guix/scripts/pull.scm65
-rw-r--r--guix/scripts/system.scm22
-rw-r--r--guix/self.scm20
-rw-r--r--guix/status.scm3
-rw-r--r--guix/ui.scm11
15 files changed, 197 insertions, 84 deletions
diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm
index 3a658e2557..ba0de1259e 100644
--- a/guix/build/ruby-build-system.scm
+++ b/guix/build/ruby-build-system.scm
@@ -86,28 +86,29 @@ operation is not deterministic, we replace it with `find`."
"Remove the original gemspec, if present, and replace it with a new one.
This avoids issues with upstream gemspecs requiring tools such as git to
generate the files list."
- (when (gem-archive? source)
- (let ((gemspec (or (false-if-exception (first-gemspec))
- ;; Make new gemspec if one wasn't shipped.
- ".gemspec")))
-
- (when (file-exists? gemspec) (delete-file gemspec))
-
- ;; Extract gemspec from source gem.
- (let ((pipe (open-pipe* OPEN_READ "gem" "spec" "--ruby" source)))
- (dynamic-wind
- (const #t)
- (lambda ()
- (call-with-output-file gemspec
- (lambda (out)
- ;; 'gem spec' writes to stdout, but 'gem build' only reads
- ;; gemspecs from a file, so we redirect the output to a file.
- (while (not (eof-object? (peek-char pipe)))
- (write-char (read-char pipe) out))))
- #t)
- (lambda ()
- (close-pipe pipe)))))
- #t))
+ (if (gem-archive? source)
+ (let ((gemspec (or (false-if-exception (first-gemspec))
+ ;; Make new gemspec if one wasn't shipped.
+ ".gemspec")))
+
+ (when (file-exists? gemspec) (delete-file gemspec))
+
+ ;; Extract gemspec from source gem.
+ (let ((pipe (open-pipe* OPEN_READ "gem" "spec" "--ruby" source)))
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (call-with-output-file gemspec
+ (lambda (out)
+ ;; 'gem spec' writes to stdout, but 'gem build' only reads
+ ;; gemspecs from a file, so we redirect the output to a file.
+ (while (not (eof-object? (peek-char pipe)))
+ (write-char (read-char pipe) out))))
+ #t)
+ (lambda ()
+ (close-pipe pipe)))))
+ (display "extract-gemspec: skipping as source is not a gem archive\n"))
+ #t)
(define* (build #:key source #:allow-other-keys)
"Build a new gem using the gemspec from the SOURCE gem."
@@ -138,11 +139,13 @@ GEM-FLAGS are passed to the 'gem' invokation, if present."
(gem-file-basename (basename gem-file))
(gem-name (substring gem-file-basename
0
- (- (string-length gem-file-basename) 4))))
+ (- (string-length gem-file-basename) 4)))
+ (gem-dir (string-append vendor-dir "/gems/" gem-name)))
(setenv "GEM_VENDOR" vendor-dir)
(or (zero?
(apply system* "gem" "install" gem-file
+ "--verbose"
"--local" "--ignore-dependencies" "--vendor"
;; Executables should go into /bin, not
;; /lib/ruby/gems.
@@ -163,7 +166,7 @@ GEM-FLAGS are passed to the 'gem' invokation, if present."
;; For gems with native extensions, several Makefile-related files
;; are created that contain timestamps or other elements making
;; them not reproducible. They are unnecessary so we remove them.
- (when (file-exists? (string-append vendor-dir "/ext"))
+ (when (file-exists? (string-append gem-dir "/ext"))
(for-each (lambda (file)
(log-file-deletion file)
(delete-file file))
@@ -172,7 +175,7 @@ GEM-FLAGS are passed to the 'gem' invokation, if present."
"page-Makefile.ri")
(find-files (string-append vendor-dir "/extensions")
"gem_make.out")
- (find-files (string-append vendor-dir "/ext")
+ (find-files (string-append gem-dir "/ext")
"Makefile"))))
#t))
diff --git a/guix/git.scm b/guix/git.scm
index 0e3ce37e26..289537dedf 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -300,6 +300,14 @@ Log progress and checkout info to LOG-PORT."
#:select? (negate dot-git?))
commit)))
+(define (print-git-error port key args default-printer)
+ (match args
+ (((? git-error? error) . _)
+ (format port (G_ "Git error: ~a~%")
+ (git-error-message error)))))
+
+(set-exception-printer! 'git-error print-git-error)
+
;;;
;;; Checkouts.
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index bfd47a831d..36b3c930d7 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -623,8 +623,7 @@ releases are on gnu.org."
(package-upstream-name package)
#:server "mirrors.mit.edu"
#:directory
- (string-append "/kde" (dirname (dirname (uri-path uri))))
- #:file->signature (const #f)))))
+ (string-append "/kde" (dirname (dirname (uri-path uri))))))))
(define (latest-xorg-release package)
"Return the latest release of PACKAGE, the name of an X.org package."
diff --git a/guix/inferior.scm b/guix/inferior.scm
index 6cfa146029..027418a98d 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -61,6 +61,7 @@
inferior-object?
inferior-packages
+ inferior-available-packages
lookup-inferior-packages
inferior-package?
@@ -256,6 +257,31 @@ equivalent. Return #f if the inferior could not be launched."
vlist-null
(inferior-packages inferior)))
+(define (inferior-available-packages inferior)
+ "Return the list of name/version pairs corresponding to the set of packages
+available in INFERIOR.
+
+This is faster and requires less resource-intensive than calling
+'inferior-packages'."
+ (if (inferior-eval '(defined? 'fold-available-packages)
+ inferior)
+ (inferior-eval '(fold-available-packages
+ (lambda* (name version result
+ #:key supported? deprecated?
+ #:allow-other-keys)
+ (if (and supported? (not deprecated?))
+ (acons name version result)
+ result))
+ '())
+ inferior)
+
+ ;; As a last resort, if INFERIOR is old and lacks
+ ;; 'fold-available-packages', fall back to 'inferior-packages'.
+ (map (lambda (package)
+ (cons (inferior-package-name package)
+ (inferior-package-version package)))
+ (inferior-packages inferior))))
+
(define* (lookup-inferior-packages inferior name #:optional version)
"Return the sorted list of inferior packages matching NAME in INFERIOR, with
highest version numbers first. If VERSION is true, return only packages with
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index 950f0f41d8..d349b5d590 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -23,7 +23,7 @@
#:use-module ((guix build utils) #:select (mkdir-p))
#:use-module ((guix serialization) #:select (restore-file))
#:use-module (guix store)
- #:use-module (guix status)
+ #:use-module ((guix status) #:select (with-status-verbosity))
#:use-module (guix grafts)
#:use-module (guix packages)
#:use-module (guix derivations)
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index fb7e04904d..6b29c470fb 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -47,7 +47,7 @@
#:autoload (guix download) (download-to-store)
#:autoload (guix git-download) (git-reference?)
#:autoload (guix git) (git-checkout?)
- #:use-module (guix status)
+ #:use-module ((guix status) #:select (with-status-verbosity))
#:use-module ((guix progress) #:select (current-terminal-columns))
#:use-module ((guix build syscalls) #:select (terminal-columns))
#:export (%standard-build-options
diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm
index be4ce4364b..ce70f2f0b3 100644
--- a/guix/scripts/copy.scm
+++ b/guix/scripts/copy.scm
@@ -21,7 +21,7 @@
#:use-module (guix scripts)
#:use-module (guix ssh)
#:use-module (guix store)
- #:use-module (guix status)
+ #:use-module ((guix status) #:select (with-status-verbosity))
#:use-module (guix utils)
#:use-module (guix derivations)
#:use-module (guix scripts build)
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 116b8dcbce..3966531efa 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -21,7 +21,7 @@
(define-module (guix scripts environment)
#:use-module (guix ui)
#:use-module (guix store)
- #:use-module (guix status)
+ #:use-module ((guix status) #:select (with-status-verbosity))
#:use-module (guix grafts)
#:use-module (guix derivations)
#:use-module (guix packages)
@@ -57,20 +57,27 @@
(define %default-shell
(or (getenv "SHELL") "/bin/sh"))
-(define (purify-environment)
- "Unset almost all environment variables. A small number of variables such
-as 'HOME' and 'USER' are left untouched."
+(define (purify-environment white-list)
+ "Unset all environment variables except those that match the regexps in
+WHITE-LIST and those listed in %PRECIOUS-VARIABLES. A small number of
+variables such as 'HOME' and 'USER' are left untouched."
(for-each unsetenv
- (remove (cut member <> %precious-variables)
+ (remove (lambda (variable)
+ (or (member variable %precious-variables)
+ (find (cut regexp-exec <> variable)
+ white-list)))
(match (get-environment-variables)
(((names . _) ...)
names)))))
-(define* (create-environment profile manifest #:key pure?)
- "Set the environment variables specified by MANIFEST for PROFILE. When PURE?
-is #t, unset the variables in the current environment. Otherwise, augment
-existing environment variables with additional search paths."
- (when pure? (purify-environment))
+(define* (create-environment profile manifest
+ #:key pure? (white-list '()))
+ "Set the environment variables specified by MANIFEST for PROFILE. When
+PURE? is #t, unset the variables in the current environment except those that
+match the regexps in WHITE-LIST. Otherwise, augment existing environment
+variables with additional search paths."
+ (when pure?
+ (purify-environment white-list))
(for-each (match-lambda
((($ <search-path-specification> variable _ separator) . value)
(let ((current (getenv variable)))
@@ -134,6 +141,8 @@ COMMAND or an interactive shell in that environment.\n"))
(display (G_ "
--pure unset existing environment variables"))
(display (G_ "
+ --inherit=REGEXP inherit environment variables that match REGEXP"))
+ (display (G_ "
--search-paths display needed environment variable definitions"))
(display (G_ "
-s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\""))
@@ -206,6 +215,11 @@ COMMAND or an interactive shell in that environment.\n"))
(option '("pure") #f #f
(lambda (opt name arg result)
(alist-cons 'pure #t result)))
+ (option '("inherit") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'inherit-regexp
+ (make-regexp* arg)
+ result)))
(option '(#\E "exec") #t #f ; deprecated
(lambda (opt name arg result)
(alist-cons 'exec (list %default-shell "-c" arg) result)))
@@ -397,25 +411,30 @@ and suitable for 'exit'."
(define primitive-exit/status (compose primitive-exit status->exit-code))
(define* (launch-environment command profile manifest
- #:key pure?)
+ #:key pure? (white-list '()))
"Run COMMAND in a new environment containing INPUTS, using the native search
paths defined by the list PATHS. When PURE?, pre-existing environment
-variables are cleared before setting the new ones."
+variables are cleared before setting the new ones, except those matching the
+regexps in WHITE-LIST."
;; Properly handle SIGINT, so pressing C-c in an interactive terminal
;; application works.
(sigaction SIGINT SIG_DFL)
- (create-environment profile manifest #:pure? pure?)
+ (create-environment profile manifest
+ #:pure? pure? #:white-list white-list)
(match command
((program . args)
(apply execlp program program args))))
-(define* (launch-environment/fork command profile manifest #:key pure?)
+(define* (launch-environment/fork command profile manifest
+ #:key pure? (white-list '()))
"Run COMMAND in a new process with an environment containing PROFILE, with
the search paths specified by MANIFEST. When PURE?, pre-existing environment
-variables are cleared before setting the new ones."
+variables are cleared before setting the new ones, except those matching the
+regexps in WHITE-LIST."
(match (primitive-fork)
(0 (launch-environment command profile manifest
- #:pure? pure?))
+ #:pure? pure?
+ #:white-list white-list))
(pid (match (waitpid pid)
((_ . status) status)))))
@@ -672,7 +691,8 @@ message if any test fails."
;; within the container.
'("/bin/sh")
(list %default-shell))))
- (mappings (pick-all opts 'file-system-mapping)))
+ (mappings (pick-all opts 'file-system-mapping))
+ (white-list (pick-all opts 'inherit-regexp)))
(when container? (assert-container-features))
@@ -741,4 +761,5 @@ message if any test fails."
(return
(exit/status
(launch-environment/fork command profile manifest
+ #:white-list white-list
#:pure? pure?))))))))))))))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 40e59a6101..3f76336abf 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -26,7 +26,7 @@
#:use-module (guix gexp)
#:use-module (guix utils)
#:use-module (guix store)
- #:use-module (guix status)
+ #:use-module ((guix status) #:select (with-status-verbosity))
#:use-module (guix grafts)
#:use-module (guix monads)
#:use-module (guix modules)
@@ -104,7 +104,9 @@ found."
;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs.
(append-map (lambda (package)
(cons package
- (package-transitive-propagated-inputs package)))
+ (match (package-transitive-propagated-inputs package)
+ (((labels packages) ...)
+ packages))))
(list guile-gcrypt guile-sqlite3)))
(define (store-database items)
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 8a71467b52..0e70315708 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -24,7 +24,7 @@
(define-module (guix scripts package)
#:use-module (guix ui)
- #:use-module (guix status)
+ #:use-module ((guix status) #:select (with-status-verbosity))
#:use-module (guix store)
#:use-module (guix grafts)
#:use-module (guix derivations)
@@ -55,6 +55,7 @@
#:autoload (gnu packages bootstrap) (%bootstrap-guile)
#:export (build-and-use-profile
delete-generations
+ delete-matching-generations
display-search-paths
guix-package))
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 3320200c07..730b6a0bf2 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -20,7 +20,7 @@
(define-module (guix scripts pull)
#:use-module (guix ui)
#:use-module (guix utils)
- #:use-module (guix status)
+ #:use-module ((guix status) #:select (with-status-verbosity))
#:use-module (guix scripts)
#:use-module (guix store)
#:use-module (guix config)
@@ -45,6 +45,7 @@
#:select (%bootstrap-guile))
#:use-module ((gnu packages certs) #:select (le-certs))
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
@@ -169,11 +170,14 @@ Download and deploy the latest version of Guix.\n"))
(reverse (profile-generations profile)))
((current previous _ ...)
(newline)
- (let ((old (fold-packages (lambda (package result)
- (alist-cons (package-name package)
- (package-version package)
- result))
- '()))
+ (let ((old (fold-available-packages
+ (lambda* (name version result
+ #:key supported? deprecated?
+ #:allow-other-keys)
+ (if (and supported? (not deprecated?))
+ (alist-cons name version result)
+ result))
+ '()))
(new (profile-package-alist
(generation-file-name profile current))))
(display-new/upgraded-packages old new
@@ -338,24 +342,24 @@ way and displaying details about the channel's source code."
(define profile-package-alist
(mlambda (profile)
"Return a name/version alist representing the packages in PROFILE."
- (fold (lambda (package lst)
- (alist-cons (inferior-package-name package)
- (inferior-package-version package)
- lst))
- '()
- (let* ((inferior (open-inferior profile))
- (packages (inferior-packages inferior)))
- (close-inferior inferior)
- packages))))
-
-(define* (display-new/upgraded-packages alist1 alist2
- #:key (heading ""))
- "Given the two package name/version alists ALIST1 and ALIST2, display the
-list of new and upgraded packages going from ALIST1 to ALIST2. When ALIST1
-and ALIST2 differ, display HEADING upfront."
+ (let* ((inferior (open-inferior profile))
+ (packages (inferior-available-packages inferior)))
+ (close-inferior inferior)
+ packages)))
+
+(define (new/upgraded-packages alist1 alist2)
+ "Compare ALIST1 and ALIST2, both of which are lists of package name/version
+pairs, and return two values: the list of packages new in ALIST2, and the list
+of packages upgraded in ALIST2."
(let* ((old (fold (match-lambda*
(((name . version) table)
- (vhash-cons name version table)))
+ (match (vhash-assoc name table)
+ (#f
+ (vhash-cons name version table))
+ ((_ . previous-version)
+ (if (version>? version previous-version)
+ (vhash-cons name version table)
+ table)))))
vlist-null
alist1))
(new (remove (match-lambda
@@ -364,14 +368,21 @@ and ALIST2 differ, display HEADING upfront."
alist2))
(upgraded (filter-map (match-lambda
((name . new-version)
- (match (vhash-fold* cons '() name old)
- (() #f)
- ((= (cut sort <> version>?) old-versions)
- (and (version>? new-version
- (first old-versions))
+ (match (vhash-assoc name old)
+ (#f #f)
+ ((_ . old-version)
+ (and (version>? new-version old-version)
(string-append name "@"
new-version))))))
alist2)))
+ (values new upgraded)))
+
+(define* (display-new/upgraded-packages alist1 alist2
+ #:key (heading ""))
+ "Given the two package name/version alists ALIST1 and ALIST2, display the
+list of new and upgraded packages going from ALIST1 to ALIST2. When ALIST1
+and ALIST2 differ, display HEADING upfront."
+ (let-values (((new upgraded) (new/upgraded-packages alist1 alist2)))
(unless (and (null? new) (null? upgraded))
(display heading))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 569b826acd..d67b9f8185 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -23,7 +23,7 @@
(define-module (guix scripts system)
#:use-module (guix config)
#:use-module (guix ui)
- #:use-module (guix status)
+ #:use-module ((guix status) #:select (with-status-verbosity))
#:use-module (guix store)
#:autoload (guix store database) (register-path)
#:use-module (guix grafts)
@@ -36,6 +36,8 @@
#:use-module (guix profiles)
#:use-module (guix scripts)
#:use-module (guix scripts build)
+ #:autoload (guix scripts package) (delete-generations
+ delete-matching-generations)
#:use-module (guix graph)
#:use-module (guix scripts graph)
#:use-module (guix build utils)
@@ -490,7 +492,8 @@ STORE is an open connection to the store."
;; Make the specified system generation the default entry.
(params (profile-boot-parameters %system-profile (list number)))
- (old-generations (delv number (generation-numbers %system-profile)))
+ (old-generations
+ (delv number (reverse (generation-numbers %system-profile))))
(old-params (profile-boot-parameters
%system-profile old-generations))
(entries (map boot-parameters->menu-entry params))
@@ -963,9 +966,11 @@ Some ACTIONS support additional ARGS.\n"))
(display (G_ "\
roll-back switch to the previous operating system configuration\n"))
(display (G_ "\
+ list-generations list the system generations\n"))
+ (display (G_ "\
switch-generation switch to an existing operating system configuration\n"))
(display (G_ "\
- list-generations list the system generations\n"))
+ delete-generations delete old system generations\n"))
(display (G_ "\
build build the operating system without installing anything\n"))
(display (G_ "\
@@ -1202,6 +1207,14 @@ argument list and OPTS is the option alist."
(apply (resolve-subcommand "search") args))
;; The following commands need to use the store, but they do not need an
;; operating system configuration file.
+ ((delete-generations)
+ (let ((pattern (match args
+ (() "")
+ ((pattern) pattern)
+ (x (leave (G_ "wrong number of arguments~%"))))))
+ (with-store store
+ (delete-matching-generations store %system-profile pattern)
+ (reinstall-bootloader store (generation-number %system-profile)))))
((switch-generation)
(let ((pattern (match args
((pattern) pattern)
@@ -1228,7 +1241,8 @@ argument list and OPTS is the option alist."
(let ((action (string->symbol arg)))
(case action
((build container vm vm-image disk-image reconfigure init
- extension-graph shepherd-graph list-generations roll-back
+ extension-graph shepherd-graph
+ list-generations delete-generations roll-back
switch-generation search docker-image)
(alist-cons 'action action result))
(else (leave (G_ "~a: unknown action~%") action))))))
diff --git a/guix/self.scm b/guix/self.scm
index a45470a0a6..ccff9be5b3 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -390,6 +390,10 @@ that provide Guile modules."
guile (guile-version (effective-version)))
"Return the 'guix' command such that it adds MODULES and DEPENDENCIES in its
load path."
+ (define glibc-utf8-locales
+ (module-ref (resolve-interface '(gnu packages base))
+ 'glibc-utf8-locales))
+
(define module-directory
;; To minimize the number of 'stat' calls needed to locate a module,
;; create the union of all the module directories.
@@ -410,6 +414,16 @@ load path."
"/site-ccache")
%load-compiled-path))
+ ;; To maximize the chances that locales are set up right
+ ;; out-of-the-box, bundle "common" UTF-8 locales.
+ (let ((locpath (getenv "GUIX_LOCPATH")))
+ (setenv "GUIX_LOCPATH"
+ (string-append (if locpath
+ (string-append locpath ":")
+ "")
+ #$(file-append glibc-utf8-locales
+ "/lib/locale"))))
+
(let ((guix-main (module-ref (resolve-interface '(guix ui))
'guix-main)))
#$(if source
@@ -757,7 +771,7 @@ Info manual."
((_ variable rest ...)
(cons `(variable . ,variable)
(variables rest ...))))))
- (variables %localstatedir %storedir %sysconfdir %system)))
+ (variables %localstatedir %storedir %sysconfdir)))
(define* (make-config.scm #:key zlib gzip xz bzip2
(package-name "GNU Guix")
@@ -775,6 +789,7 @@ Info manual."
%guix-version
%guix-bug-report-address
%guix-home-page-url
+ %system
%store-directory
%state-directory
%store-database-directory
@@ -784,6 +799,9 @@ Info manual."
%bzip2
%xz))
+ (define %system
+ #$(%current-system))
+
#$@(map (match-lambda
((name . value)
#~(define-public #$name #$value)))
diff --git a/guix/status.scm b/guix/status.scm
index cd5027ef17..bddaa003db 100644
--- a/guix/status.scm
+++ b/guix/status.scm
@@ -506,6 +506,7 @@ addition to build events."
(match event
(('build-started drv . _)
+ (erase-current-line*)
(let ((properties (derivation-properties
(read-derivation-from-file drv))))
(match (assq-ref properties 'type)
@@ -552,10 +553,12 @@ addition to build events."
(format port (info (G_ "View build log at '~a'.")) log)))
(newline port))
(('substituter-started item _ ...)
+ (erase-current-line*)
(when (or print-log? (not (extended-build-trace-supported?)))
(format port (info (G_ "substituting ~a...")) item)
(newline port)))
(('download-started item uri _ ...)
+ (erase-current-line*)
(format port (info (G_ "downloading from ~a...")) uri)
(newline port))
(('download-progress item uri
diff --git a/guix/ui.scm b/guix/ui.scm
index f0465519b6..2fc001d2eb 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -374,9 +374,16 @@ ARGS is the list of arguments received by the 'throw' handler."
(report-error (G_ "exception thrown: ~s~%") obj))
(when (fix-hint? obj)
(display-hint (condition-fix-hint obj))))
- ((error args ...)
+ ((key args ...)
(report-error (G_ "failed to load '~a':~%") file)
- (apply display-error frame (current-error-port) args))))
+ (match args
+ (((? symbol? proc) (? string? message) (args ...) . rest)
+ (display-error frame (current-error-port) proc message
+ args rest))
+ (_
+ ;; Some exceptions like 'git-error' do not follow Guile's convention
+ ;; above and need to be printed with 'print-exception'.
+ (print-exception (current-error-port) frame key args))))))
(define (warn-about-load-error file args) ;FIXME: factorize with ↑
"Report the failure to load FILE, a user-provided Scheme file, without