[bug#32115] [PATCH 2/2] pull: Use (guix inferior) to display new and upgraded packages.

[Ludovic Courtès]

* guix/scripts/pull.scm (display-profile-content): Call
'display-generation'.
(display-profile-content-diff): New procedure.
(process-query)[list-generation]: Remove.
[list-generations]: New procedure.
Adjust accordingly.
* doc/guix.texi (Invoking guix pull): Update example of '-l'.
---
 doc/guix.texi         |  6 +++
 guix/scripts/pull.scm | 91 +++++++++++++++++++++++++++++++++++++------
 2 files changed, 86 insertions(+), 11 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index e93b320e8..3e4bceb8a 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 7202e3cc1..c61432b04 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -29,6 +29,7 @@
   #:use-module (guix gexp)
   #:use-module (guix grafts)
   #: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 +46,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 +292,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 +314,68 @@ 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 (display-profile-content-diff profile gen1 gen2)
+  "Display the changes in PROFILE GEN2 compared to generation GEN1."
+  (define (package-alist generation)
+    (fold (lambda (package lst)
+            (alist-cons (inferior-package-name package)
+                        (inferior-package-version package)
+                        lst))
+          '()
+          (let* ((directory (generation-file-name profile generation))
+                 (inferior  (open-inferior directory))
+                 (packages  (inferior-packages inferior)))
+            (close-inferior inferior)
+            packages)))
+
+  (display-profile-content profile gen2)
+  (let* ((gen1     (fold (match-lambda*
+                           (((name . version) table)
+                            (vhash-cons name version table)))
+                         vlist-null
+                         (package-alist gen1)))
+         (gen2     (package-alist gen2))
+         (new      (remove (match-lambda
+                             ((name . _)
+                              (vhash-assoc name gen1)))
+                           gen2))
+         (upgraded (filter-map (match-lambda
+                                 ((name . new-version)
+                                  (match (vhash-fold* cons '() name gen1)
+                                    (() #f)
+                                    ((= (cut sort <> version>?) old-versions)
+                                     (and (version>? new-version
+                                                     (first old-versions))
+                                          (string-append name "@"
+                                                         new-version))))))
+                               gen2)))
+    (unless (null? new)
+      (format #t (G_ "  ~h new packages: ~a~%") (length new)
+              (indented-string
+               (fill-paragraph (string-join (sort (map first new) string<?)
+                                            ", ")
+                               (- (%text-width) 4) 30)
+               4)))
+    (unless (null? upgraded)
+      (format #t (G_ "  ~h packages upgraded: ~a~%") (length upgraded)
+              (indented-string
+               (fill-paragraph (string-join (sort upgraded string<?) ", ")
+                               (- (%text-width) 4) 35)
+               4)))))
+
 (define (process-query opts)
   "Process any query specified by OPTS."
   (define profile
@@ -317,29 +383,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)
-- 
2.18.0