[PATCH] guix: refresh: Add --list-dependent option.

[Eric Bavier]

Comments or suggestions welcome, in particular regarding the format of
the output.

>From 57aa3ac9bf0a58c0981fbf729dd12756dedd5831 Mon Sep 17 00:00:00 2001
From: Eric Bavier <address@hidden>
Date: Thu, 17 Jul 2014 12:42:01 -0500
Subject: [PATCH] guix: refresh: Add --list-dependent option.

* guix/utils.scm (fold-tree, fold-tree-leaves): New functions.
* tests/utils.scm: Add tests for fold-tree and fold-tree-leaves.
* guix/packages.scm (package-direct-inputs): New procedure.
* gnu/packages.scm (vhash-refq, package-dependencies, package-direct-dependents)
  (package-transitive-dependents, package-covering-dependents): New procedures.
* guix/scripts/refresh.scm (%options, show-help, guix-refresh): Add
  --list-dependent option.
---
 gnu/packages.scm         |   65 ++++++++++++++++++++++++++++++++++-
 guix/packages.scm        |   12 +++++--
 guix/scripts/refresh.scm |   85 ++++++++++++++++++++++++++++++++--------------
 guix/utils.scm           |   33 ++++++++++++++++++
 tests/utils.scm          |   35 ++++++++++++++++++-
 5 files changed, 199 insertions(+), 31 deletions(-)

diff --git a/gnu/packages.scm b/gnu/packages.scm
index 8365a00..01710f0 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 <address@hidden>
 ;;; Copyright © 2013 Mark H Weaver <address@hidden>
+;;; Copyright © 2014 Eric Bavier <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -31,10 +32,17 @@
             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-dependencies
+            package-direct-dependents
+            package-transitive-dependents
+            package-covering-dependents))
 
 ;;; Commentary:
 ;;;
@@ -182,3 +190,58 @@ 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
+         (map cadr (package-direct-inputs package))))
+      vlist-null))))
+
+(define (package-direct-dependents . packages)
+  "Return a list of packages 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 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.
+     (apply package-direct-dependents packages))))
+
+(define (package-covering-dependents . packages)
+  "Return a minimal list of packages 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.
+     (apply package-direct-dependents packages))))
diff --git a/guix/packages.scm b/guix/packages.scm
index b413e58..fa2d1e6 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
@@ -473,12 +474,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 c65a7d0..91da70c 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 <address@hidden>
 ;;; Copyright © 2013 Nikita Karetnikov <address@hidden>
+;;; Copyright © 2014 Eric Bavier <address@hidden>
 ;;;
 ;;; 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,50 @@ 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
+                              (apply package-covering-dependents
+                                     packages)))
+               ;; Wasteful to build a list merely to get its length, so
+               ;; calculate the length directly.
+               (total-rebuilt
+                (fold-tree
+                 (lambda (_ r) (1+ r)) 0
+                 (lambda (node)
+                   (and=> (vhash-assq node (package-dependencies)) cdr))
+                 packages)))
+          (format (current-output-port)
+                  (N_ "No dependents other than itself: ~3*~{~a~}~%"
+                      (N_ "Building the following package ensures ~*~d \
+dependent packages are rebuilt: ~{~a~^ ~}~%"
+                          "Building the following ~d packages would ensure ~d \
+dependent packages are rebuilt: ~{~a~^ ~}~%"
+                          (length rebuilds))
+                      total-rebuilt)
+                  (length rebuilds) total-rebuilt rebuilds
+                  (map package-full-name packages))))
+       (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))))))
diff --git a/guix/utils.scm b/guix/utils.scm
index 700a191..b61ff24 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2013 Mark H Weaver <address@hidden>
+;;; Copyright © 2014 Eric Bavier <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -72,6 +73,8 @@
             call-with-temporary-output-file
             with-atomic-file-output
             fold2
+            fold-tree
+            fold-tree-leaves
 
             filtered-port
             compressed-port
@@ -649,6 +652,36 @@ output port, and PROC's result is returned."
              (lambda (result1 result2)
                (fold2 proc result1 result2 (cdr lst1) (cdr lst2)))))))))
 
+(define (fold-tree proc init children roots)
+  "Call (PROC NODE RESULT) for each node in the tree that is reachable from
+ROOTS, using INIT as the initial value of RESULT.  The order in which nodes
+are traversed is not specified, however, each node is visited only once, based
+on an eq? check.  Children of a node to be visited are generated by
+calling (CHILDREN NODE), the result of which should be a list of nodes that
+are connected to NODE in the tree, or '() or #f if NODE is a leaf node."
+  (let loop ((result init)
+             (seen vlist-null)
+             (lst roots))
+    (match lst
+      (() result)
+      ((head . tail)
+       (if (not (vhash-assq head seen))
+           (loop (proc head result)
+                 (vhash-consq head #t seen)
+                 (match (children head)
+                   ((or () #f) tail)
+                   (children (append tail children))))
+           (loop result seen tail))))))
+
+(define (fold-tree-leaves proc init children roots)
+  "Like fold-tree, but call (PROC NODE RESULT) only for leaf nodes."
+  (fold-tree
+   (lambda (node result)
+     (match (children node)
+       ((or () #f) (proc node result))
+       (else result)))
+   init children roots))
+
 
 ;;;
 ;;; Source location.
diff --git a/tests/utils.scm b/tests/utils.scm
index 8ad399f..611867c 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <address@hidden>
+;;; Copyright © 2014 Eric Bavier <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -25,7 +26,8 @@
   #:use-module (srfi srfi-64)
   #:use-module (rnrs bytevectors)
   #:use-module (rnrs io ports)
-  #:use-module (ice-9 match))
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 vlist))
 
 (define temp-file
   (string-append "t-utils-" (number->string (getpid))))
@@ -118,6 +120,37 @@
                '(0 1 2 3)))
     list))
 
+(let* ((tree (alist->vhash
+              '((0 2 3) (1 3 4) (2) (3 5 6) (4 6) (5) (6))
+              hashq))
+       (add-one (lambda (_ r) (1+ r)))
+       (tree-lookup (lambda (n) (cdr (vhash-assq n tree)))))
+  (test-equal "fold-tree, single root"
+    5 (fold-tree add-one 0 tree-lookup '(0)))
+  (test-equal "fold-tree, two roots"
+    7 (fold-tree add-one 0 tree-lookup '(0 1)))
+  (test-equal "fold-tree, sum"
+    16 (fold-tree + 0 tree-lookup '(0)))
+  (test-equal "fold-tree, internal"
+    18 (fold-tree + 0 tree-lookup '(3 4)))
+  (test-equal "fold-tree, cons"
+    '(1 3 4 5 6)
+    (sort (fold-tree cons '() tree-lookup '(1)) <))
+  (test-equal "fold-tree, overlapping paths"
+    '(1 3 4 5 6)
+    (sort (fold-tree cons '() tree-lookup '(1 4)) <))
+  (test-equal "fold-tree, cons, two roots"
+    '(0 2 3 4 5 6)
+    (sort (fold-tree cons '() tree-lookup '(0 4)) <))
+  (test-equal "fold-tree-leaves, single root"
+    2 (fold-tree-leaves add-one 0 tree-lookup '(1)))
+  (test-equal "fold-tree-leaves, single root, sum"
+    11 (fold-tree-leaves + 0 tree-lookup '(1)))
+  (test-equal "fold-tree-leaves, two roots"
+    3 (fold-tree-leaves add-one 0 tree-lookup '(0 1)))
+  (test-equal "fold-tree-leaves, two roots, sum"
+    13 (fold-tree-leaves + 0 tree-lookup '(0 1))))
+
 (test-assert "filtered-port, file"
   (let* ((file  (search-path %load-path "guix.scm"))
          (input (open-file file "r0b")))
-- 
1.7.9.5

-- 
Eric Bavier