diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/git.scm | 8 | ||||
| -rw-r--r-- | guix/inferior.scm | 26 | ||||
| -rw-r--r-- | guix/scripts/archive.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/copy.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 6 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 3 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 63 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 22 | ||||
| -rw-r--r-- | guix/status.scm | 3 | ||||
| -rw-r--r-- | guix/ui.scm | 11 |
12 files changed, 111 insertions, 39 deletions
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/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..3143ea9281 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) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index b19a4ae1b1..86e15d9bab 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)))) + (let* ((inferior (open-inferior profile)) + (packages (inferior-available-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." +(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/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 |