summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2018-07-10 16:06:32 +0200
committerLudovic Courtès <ludo@gnu.org>2018-07-13 17:28:40 +0200
commitdc733e6a12ef4c351bfd2d876784c816a245d575 (patch)
tree76231b4b24d03afcc33c96c16694dd991cf8506f
parent2ca299caf64489f4e1e665ec1158fb0309b0b565 (diff)
downloadpatches-dc733e6a12ef4c351bfd2d876784c816a245d575.tar
patches-dc733e6a12ef4c351bfd2d876784c816a245d575.tar.gz
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'.
-rw-r--r--doc/guix.texi6
-rw-r--r--guix/scripts/pull.scm109
2 files changed, 104 insertions, 11 deletions
diff --git a/doc/guix.texi b/doc/guix.texi
index 7a5ddefd4e..c759ccb119 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -2786,12 +2786,18 @@ Generation 2 Jun 11 2018 11:02:49
repository URL: https://git.savannah.gnu.org/git/guix.git
branch: origin/master
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)
guix 844cc1c
repository URL: https://git.savannah.gnu.org/git/guix.git
branch: origin/master
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
This @code{~/.config/guix/current} profile works like any other profile
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 7202e3cc16..aa77434334 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -28,7 +28,9 @@
#:use-module (guix profiles)
#:use-module (guix gexp)
#:use-module (guix grafts)
+ #:use-module (guix memoization)
#:use-module (guix monads)
+ #:autoload (guix inferior) (open-inferior)
#:use-module (guix scripts build)
#:autoload (guix self) (whole-package)
#:autoload (gnu packages ssh) (guile-ssh)
@@ -45,9 +47,11 @@
#: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-35)
#:use-module (srfi srfi-37)
#:use-module (ice-9 match)
+ #:use-module (ice-9 vlist)
#:export (guix-pull))
(module-autoload! (resolve-module '(guix scripts pull))
@@ -289,6 +293,7 @@ certificates~%"))
(define (display-profile-content profile number)
"Display the packages in PROFILE, generation NUMBER, in a human-readable
way and displaying details about the channel's source code."
+ (display-generation profile number)
(for-each (lambda (entry)
(format #t " ~a ~a~%"
(manifest-entry-name entry)
@@ -310,6 +315,85 @@ way and displaying details about the channel's source code."
(manifest-entries
(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)
"Process any query specified by OPTS."
(define profile
@@ -317,29 +401,32 @@ way and displaying details about the channel's source code."
(match (assoc-ref opts 'query)
(('list-generations pattern)
- (define (list-generation display-function number)
- (unless (zero? number)
- (display-generation profile number)
- (display-function profile number)
- (newline)))
+ (define (list-generations profile numbers)
+ (match numbers
+ ((first rest ...)
+ (display-profile-content profile first)
+ (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
(cond ((not (file-exists? profile)) ; XXX: race condition
(raise (condition (&profile-not-found-error
(profile profile)))))
((string-null? pattern)
- (for-each (lambda (generation)
- (list-generation display-profile-content generation))
- (profile-generations profile)))
+ (list-generations profile (profile-generations profile)))
((matching-generations pattern profile)
=>
(match-lambda
(()
(exit 1))
((numbers ...)
- (for-each (lambda (generation)
- (list-generation display-profile-content generation))
- numbers)))))))))
+ (list-generations profile numbers)))))))))
(define (guix-pull . args)