guix: refresh: Add --list-dependent option.

* guix/packages.scm (package-direct-inputs): New procedure.
* gnu/packages.scm (vhash-refq, package-direct-dependents)
  (package-transitive-dependents, package-covering-dependents): New procedures.
* guix/scripts/refresh.scm (%options, show-help, guix-refresh): Add
  --list-dependent option.
* doc/guix.texi (Invoking guix refresh): Document '--list-dependent' option.

4 files changed, 156 insertions, 30 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index 5bee540460..8431cbd907 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -2545,6 +2545,31 @@ The command above specifically updates the @code{emacs} and
 @code{idutils} packages.  The @code{--select} option would have no
 effect in this case.
 
+When considering whether to upgrade a package, it is sometimes
+convenient to know which packages would be affected by the upgrade and
+should be checked for compatibility.  For this the following option may
+be used when passing @command{guix refresh} one or more package names:
+
+@table @code
+
+@item --list-dependent
+@itemx -l
+List top-level dependent packages that would need to be rebuilt as a
+result of upgrading one or more packages.
+
+@end table
+
+Be aware that the @code{--list-dependent} option only
+@emph{approximates} the rebuilds that would be required as a result of
+an upgrade.  More rebuilds might be required under some circumstances.
+
+@example
+guix refresh --list-dependent flex
+@end example
+
+The command above lists a set of packages that could be built to check
+for compatibility with an upgraded @code{flex} package.
+
 The following options can be used to customize GnuPG operation:
 
 @table @code
diff --git a/gnu/packages.scm b/gnu/packages.scm
index 8365a00051..77d9d3ee82 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -31,10 +32,16 @@
             search-bootstrap-binary
             %patch-directory
             %bootstrap-binaries-path
+
             fold-packages
+
             find-packages-by-name
             find-best-packages-by-name
-            find-newest-available-packages))
+            find-newest-available-packages
+
+            package-direct-dependents
+            package-transitive-dependents
+            package-covering-dependents))
 
 ;;; Commentary:
 ;;;
@@ -182,3 +189,60 @@ VERSION."
       (match (vhash-assoc name (find-newest-available-packages))
         ((_ version pkgs ...) pkgs)
         (#f '()))))
+
+
+(define* (vhash-refq vhash key #:optional (dflt #f))
+  "Look up KEY in the vhash VHASH, and return the value (if any) associated
+with it.  If KEY is not found, return DFLT (or `#f' if no DFLT argument is
+supplied).  Uses `eq?' for equality testing."
+  (or (and=> (vhash-assq key vhash) cdr)
+      dflt))
+
+(define package-dependencies
+  (memoize
+   (lambda ()
+     "Return a vhash keyed by package, and with associated values that are a
+list of packages that depend on that package."
+     (fold-packages
+      (lambda (package dag)
+        (fold
+         (lambda (in d)
+           ;; Insert a graph edge from each of package's inputs to package.
+           (vhash-consq in
+                        (cons package (vhash-refq d in '()))
+                        (vhash-delq in d)))
+         dag
+         (match (package-direct-inputs package)
+           (((labels packages . _) ...)
+            packages) )))
+      vlist-null))))
+
+(define (package-direct-dependents packages)
+  "Return a list of packages from the distribution that directly depend on the
+packages in PACKAGES."
+  (delete-duplicates
+   (concatenate
+    (map (lambda (p)
+           (vhash-refq (package-dependencies) p '()))
+         packages))))
+
+(define (package-transitive-dependents packages)
+  "Return the transitive dependent packages of the distribution packages in
+PACKAGES---i.e. the dependents of those packages, plus their dependents,
+recursively."
+  (let ((dependency-dag (package-dependencies)))
+    (fold-tree
+     cons '()
+     (lambda (node) (vhash-refq dependency-dag node))
+     ;; Start with the dependents to avoid including PACKAGES in the result.
+     (package-direct-dependents packages))))
+
+(define (package-covering-dependents packages)
+  "Return a minimal list of packages from the distribution whose dependencies
+include all of PACKAGES and all packages that depend on PACKAGES."
+  (let ((dependency-dag (package-dependencies)))
+    (fold-tree-leaves
+     cons '()
+     (lambda (node) (vhash-refq dependency-dag node))
+     ;; Start with the dependents to avoid including PACKAGES in the result.
+     (package-direct-dependents packages))))
diff --git a/guix/packages.scm b/guix/packages.scm
index 985a573fd3..5c3da9f2ff 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -75,6 +75,7 @@
             package-location
             package-field-location
 
+            package-direct-inputs
             package-transitive-inputs
             package-transitive-target-inputs
             package-transitive-native-inputs
@@ -484,12 +485,17 @@ IMPORTED-MODULES specify modules to use/import for use by SNIPPET."
       ((input rest ...)
        (loop rest (cons input result))))))
 
+(define (package-direct-inputs package)
+  "Return all the direct inputs of PACKAGE---i.e, its direct inputs along
+with their propagated inputs."
+  (append (package-native-inputs package)
+          (package-inputs package)
+          (package-propagated-inputs package)))
+
 (define (package-transitive-inputs package)
   "Return the transitive inputs of PACKAGE---i.e., its direct inputs along
 with their propagated inputs, recursively."
-  (transitive-inputs (append (package-native-inputs package)
-                             (package-inputs package)
-                             (package-propagated-inputs package))))
+  (transitive-inputs (package-direct-inputs package)))
 
 (define (package-transitive-target-inputs package)
   "Return the transitive target inputs of PACKAGE---i.e., its direct inputs
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index af7beb748b..17d75b33ca 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
+;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -29,6 +30,7 @@
   #:use-module ((gnu packages base) #:select (%final-inputs))
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
+  #:use-module (ice-9 vlist)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
@@ -59,6 +61,9 @@
                     (x
                      (leave (_ "~a: invalid selection; expected `core' or `non-core'")
                             arg)))))
+        (option '(#\l "list-dependent") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'list-dependent? #t result)))
 
         (option '("key-server") #t #f
                 (lambda (opt name arg result)
@@ -96,6 +101,9 @@ specified with `--select'.\n"))
   (display (_ "
   -s, --select=SUBSET    select all the packages in SUBSET, one of
                          `core' or `non-core'"))
+  (display (_ "
+  -l, --list-dependent   list top-level dependent packages that would need to
+                         be rebuilt as a result of upgrading PACKAGE..."))
   (newline)
   (display (_ "
       --key-server=HOST  use HOST as the OpenPGP key server"))
@@ -193,9 +201,10 @@ update would trigger a complete rebuild."
         ;; XXX: Fails to catch MPFR/MPC, whose *source* is used as input.
         (member (package-name package) names))))
 
-  (let* ((opts         (parse-options))
-         (update?      (assoc-ref opts 'update?))
-         (key-download (assoc-ref opts 'key-download))
+  (let* ((opts            (parse-options))
+         (update?         (assoc-ref opts 'update?))
+         (list-dependent? (assoc-ref opts 'list-dependent?))
+         (key-download    (assoc-ref opts 'key-download))
          (packages
           (match (concatenate
                   (filter-map (match-lambda
@@ -220,26 +229,48 @@ update would trigger a complete rebuild."
                  (some                        ; user-specified packages
                   some))))
     (with-error-handling
-      (if update?
-          (let ((store (open-connection)))
-            (parameterize ((%openpgp-key-server
-                            (or (assoc-ref opts 'key-server)
-                                (%openpgp-key-server)))
-                           (%gpg-command
-                            (or (assoc-ref opts 'gpg-command)
-                                (%gpg-command))))
-              (for-each
-               (cut update-package store <> #:key-download key-download)
-               packages)))
-          (for-each (lambda (package)
-                      (match (false-if-exception (package-update-path package))
-                        ((new-version . directory)
-                         (let ((loc (or (package-field-location package 'version)
-                                        (package-location package))))
-                           (format (current-error-port)
-                                   (_ "~a: ~a would be upgraded from ~a to ~a~%")
-                                   (location->string loc)
-                                   (package-name package) (package-version package)
-                                   new-version)))
-                        (_ #f)))
-                    packages)))))
+      (cond
+       (list-dependent?
+        (let* ((rebuilds (map package-full-name
+                              (package-covering-dependents packages)))
+               (total-dependents
+                (length (package-transitive-dependents packages))))
+          (if (= total-dependents 0)
+              (format (current-output-port)
+                      (N_ "No dependents other than itself: ~{~a~}~%"
+                          "No dependents other than themselves: ~{~a~^ ~}~%"
+                          (length packages))
+                      (map package-full-name packages))
+              (format (current-output-port)
+                      (N_ (N_ "A single dependent package: ~2*~{~a~}~%"
+                              "Building the following package would ensure ~d \
+dependent packages are rebuilt; ~*~{~a~^ ~}~%"
+                              total-dependents)
+                          "Building the following ~d packages would ensure ~d \
+dependent packages are rebuilt: ~{~a~^ ~}~%"
+                          (length rebuilds))
+                      (length rebuilds) total-dependents rebuilds))))
+       (update?
+        (let ((store (open-connection)))
+          (parameterize ((%openpgp-key-server
+                          (or (assoc-ref opts 'key-server)
+                              (%openpgp-key-server)))
+                         (%gpg-command
+                          (or (assoc-ref opts 'gpg-command)
+                              (%gpg-command))))
+            (for-each
+             (cut update-package store <> #:key-download key-download)
+             packages))))
+       (else
+        (for-each (lambda (package)
+                    (match (false-if-exception (package-update-path package))
+                      ((new-version . directory)
+                       (let ((loc (or (package-field-location package 'version)
+                                      (package-location package))))
+                         (format (current-error-port)
+                                 (_ "~a: ~a would be upgraded from ~a to ~a~%")
+                                 (location->string loc)
+                                 (package-name package) (package-version package)
+                                 new-version)))
+                      (_ #f)))
+                  packages))))))