diff options
Diffstat (limited to 'guix/scripts')
| -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 |
8 files changed, 65 insertions, 37 deletions
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)))))) |