pull: Use (guix inferior) to display new and upgraded packages.
* guix/scripts/pull.scm (display-profile-content): Call 'display-generation'. (display-new/upgraded-packages, display-profile-content-diff): New procedures. (process-query)[list-generation]: Remove. [list-generations]: New procedure. Adjust accordingly. * doc/guix.texi (Invoking guix pull): Update example of '-l'.
This commit is contained in:
parent
2ca299caf6
commit
dc733e6a12
|
@ -2786,12 +2786,18 @@ Generation 2 Jun 11 2018 11:02:49
|
||||||
repository URL: https://git.savannah.gnu.org/git/guix.git
|
repository URL: https://git.savannah.gnu.org/git/guix.git
|
||||||
branch: origin/master
|
branch: origin/master
|
||||||
commit: e0cc7f669bec22c37481dd03a7941c7d11a64f1d
|
commit: e0cc7f669bec22c37481dd03a7941c7d11a64f1d
|
||||||
|
2 new packages: keepalived, libnfnetlink
|
||||||
|
6 packages upgraded: emacs-nix-mode@@2.0.4,
|
||||||
|
guile2.0-guix@@0.14.0-12.77a1aac, guix@@0.14.0-12.77a1aac,
|
||||||
|
heimdal@@7.5.0, milkytracker@@1.02.00, nix@@2.0.4
|
||||||
|
|
||||||
Generation 3 Jun 13 2018 23:31:07 (current)
|
Generation 3 Jun 13 2018 23:31:07 (current)
|
||||||
guix 844cc1c
|
guix 844cc1c
|
||||||
repository URL: https://git.savannah.gnu.org/git/guix.git
|
repository URL: https://git.savannah.gnu.org/git/guix.git
|
||||||
branch: origin/master
|
branch: origin/master
|
||||||
commit: 844cc1c8f394f03b404c5bb3aee086922373490c
|
commit: 844cc1c8f394f03b404c5bb3aee086922373490c
|
||||||
|
28 new packages: emacs-helm-ls-git, emacs-helm-mu, @dots{}
|
||||||
|
69 packages upgraded: borg@@1.1.6, cheese@@3.28.0, @dots{}
|
||||||
@end example
|
@end example
|
||||||
|
|
||||||
This @code{~/.config/guix/current} profile works like any other profile
|
This @code{~/.config/guix/current} profile works like any other profile
|
||||||
|
|
|
@ -28,7 +28,9 @@
|
||||||
#:use-module (guix profiles)
|
#:use-module (guix profiles)
|
||||||
#:use-module (guix gexp)
|
#:use-module (guix gexp)
|
||||||
#:use-module (guix grafts)
|
#:use-module (guix grafts)
|
||||||
|
#:use-module (guix memoization)
|
||||||
#:use-module (guix monads)
|
#:use-module (guix monads)
|
||||||
|
#:autoload (guix inferior) (open-inferior)
|
||||||
#:use-module (guix scripts build)
|
#:use-module (guix scripts build)
|
||||||
#:autoload (guix self) (whole-package)
|
#:autoload (guix self) (whole-package)
|
||||||
#:autoload (gnu packages ssh) (guile-ssh)
|
#:autoload (gnu packages ssh) (guile-ssh)
|
||||||
|
@ -45,9 +47,11 @@
|
||||||
#:use-module ((gnu packages certs) #:select (le-certs))
|
#:use-module ((gnu packages certs) #:select (le-certs))
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
#:use-module (srfi srfi-11)
|
#:use-module (srfi srfi-11)
|
||||||
|
#:use-module (srfi srfi-26)
|
||||||
#:use-module (srfi srfi-35)
|
#:use-module (srfi srfi-35)
|
||||||
#:use-module (srfi srfi-37)
|
#:use-module (srfi srfi-37)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
|
#:use-module (ice-9 vlist)
|
||||||
#:export (guix-pull))
|
#:export (guix-pull))
|
||||||
|
|
||||||
(module-autoload! (resolve-module '(guix scripts pull))
|
(module-autoload! (resolve-module '(guix scripts pull))
|
||||||
|
@ -289,6 +293,7 @@ certificates~%"))
|
||||||
(define (display-profile-content profile number)
|
(define (display-profile-content profile number)
|
||||||
"Display the packages in PROFILE, generation NUMBER, in a human-readable
|
"Display the packages in PROFILE, generation NUMBER, in a human-readable
|
||||||
way and displaying details about the channel's source code."
|
way and displaying details about the channel's source code."
|
||||||
|
(display-generation profile number)
|
||||||
(for-each (lambda (entry)
|
(for-each (lambda (entry)
|
||||||
(format #t " ~a ~a~%"
|
(format #t " ~a ~a~%"
|
||||||
(manifest-entry-name entry)
|
(manifest-entry-name entry)
|
||||||
|
@ -310,6 +315,85 @@ way and displaying details about the channel's source code."
|
||||||
(manifest-entries
|
(manifest-entries
|
||||||
(profile-manifest (generation-file-name profile number))))))
|
(profile-manifest (generation-file-name profile number))))))
|
||||||
|
|
||||||
|
(define (indented-string str indent)
|
||||||
|
"Return STR with each newline preceded by IDENT spaces."
|
||||||
|
(define indent-string
|
||||||
|
(make-list indent #\space))
|
||||||
|
|
||||||
|
(list->string
|
||||||
|
(string-fold-right (lambda (chr result)
|
||||||
|
(if (eqv? chr #\newline)
|
||||||
|
(cons chr (append indent-string result))
|
||||||
|
(cons chr result)))
|
||||||
|
'()
|
||||||
|
str)))
|
||||||
|
|
||||||
|
(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)
|
||||||
|
"Given the two package name/version alists ALIST1 and ALIST2, display the
|
||||||
|
list of new and upgraded packages going from ALIST1 to ALIST2."
|
||||||
|
(let* ((old (fold (match-lambda*
|
||||||
|
(((name . version) table)
|
||||||
|
(vhash-cons name version table)))
|
||||||
|
vlist-null
|
||||||
|
alist1))
|
||||||
|
(new (remove (match-lambda
|
||||||
|
((name . _)
|
||||||
|
(vhash-assoc name old)))
|
||||||
|
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))
|
||||||
|
(string-append name "@"
|
||||||
|
new-version))))))
|
||||||
|
alist2)))
|
||||||
|
(match (length new)
|
||||||
|
(0 #t)
|
||||||
|
(count
|
||||||
|
(format #t (N_ " ~h new package: ~a~%"
|
||||||
|
" ~h new packages: ~a~%" count)
|
||||||
|
count
|
||||||
|
(indented-string
|
||||||
|
(fill-paragraph (string-join (sort (map first new) string<?)
|
||||||
|
", ")
|
||||||
|
(- (%text-width) 4) 30)
|
||||||
|
4))))
|
||||||
|
(match (length upgraded)
|
||||||
|
(0 #t)
|
||||||
|
(count
|
||||||
|
(format #t (N_ " ~h package upgraded: ~a~%"
|
||||||
|
" ~h packages upgraded: ~a~%" count)
|
||||||
|
count
|
||||||
|
(indented-string
|
||||||
|
(fill-paragraph (string-join (sort upgraded string<?) ", ")
|
||||||
|
(- (%text-width) 4) 35)
|
||||||
|
4))))))
|
||||||
|
|
||||||
|
(define (display-profile-content-diff profile gen1 gen2)
|
||||||
|
"Display the changes in PROFILE GEN2 compared to generation GEN1."
|
||||||
|
(define (package-alist generation)
|
||||||
|
(profile-package-alist (generation-file-name profile generation)))
|
||||||
|
|
||||||
|
(display-profile-content profile gen2)
|
||||||
|
(display-new/upgraded-packages (package-alist gen1)
|
||||||
|
(package-alist gen2)))
|
||||||
|
|
||||||
(define (process-query opts)
|
(define (process-query opts)
|
||||||
"Process any query specified by OPTS."
|
"Process any query specified by OPTS."
|
||||||
(define profile
|
(define profile
|
||||||
|
@ -317,29 +401,32 @@ way and displaying details about the channel's source code."
|
||||||
|
|
||||||
(match (assoc-ref opts 'query)
|
(match (assoc-ref opts 'query)
|
||||||
(('list-generations pattern)
|
(('list-generations pattern)
|
||||||
(define (list-generation display-function number)
|
(define (list-generations profile numbers)
|
||||||
(unless (zero? number)
|
(match numbers
|
||||||
(display-generation profile number)
|
((first rest ...)
|
||||||
(display-function profile number)
|
(display-profile-content profile first)
|
||||||
(newline)))
|
(let loop ((numbers numbers))
|
||||||
|
(match numbers
|
||||||
|
((first second rest ...)
|
||||||
|
(display-profile-content-diff profile
|
||||||
|
first second)
|
||||||
|
(loop (cons second rest)))
|
||||||
|
((_) #t)
|
||||||
|
(() #t))))))
|
||||||
|
|
||||||
(leave-on-EPIPE
|
(leave-on-EPIPE
|
||||||
(cond ((not (file-exists? profile)) ; XXX: race condition
|
(cond ((not (file-exists? profile)) ; XXX: race condition
|
||||||
(raise (condition (&profile-not-found-error
|
(raise (condition (&profile-not-found-error
|
||||||
(profile profile)))))
|
(profile profile)))))
|
||||||
((string-null? pattern)
|
((string-null? pattern)
|
||||||
(for-each (lambda (generation)
|
(list-generations profile (profile-generations profile)))
|
||||||
(list-generation display-profile-content generation))
|
|
||||||
(profile-generations profile)))
|
|
||||||
((matching-generations pattern profile)
|
((matching-generations pattern profile)
|
||||||
=>
|
=>
|
||||||
(match-lambda
|
(match-lambda
|
||||||
(()
|
(()
|
||||||
(exit 1))
|
(exit 1))
|
||||||
((numbers ...)
|
((numbers ...)
|
||||||
(for-each (lambda (generation)
|
(list-generations profile numbers)))))))))
|
||||||
(list-generation display-profile-content generation))
|
|
||||||
numbers)))))))))
|
|
||||||
|
|
||||||
|
|
||||||
(define (guix-pull . args)
|
(define (guix-pull . args)
|
||||||
|
|
Loading…
Reference in New Issue