[PATCH] gnu: refresh: Add --list-upstream-closure option.

[Eric Bavier <ericbavier@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 791 bytes --]

When upgrading packages, I found it would be useful, in order to avoid
breaking builds for hydra and everyone else, to know which packages to
test building locally before pushing the upgrades.

The attached patch provides this information in the form of a new option
to the "guix refresh" command.  I thought that would be a nice for the
functionality because it is already a "developer" command, and the
use-case I had in mind revolved around upgrading packages.

For the sake of brevity and human consumption, the option doesn't print
*all* upstream packages, just the "top-level" upstream packages,
i.e. those whose inputs encompass all other upstream packages.

I'm not sure that the option name or all the terminology I used is
appropriate, so any comments or suggestions are welcome.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-guix-refresh-Add-list-upstream-closure-option.patch --]
[-- Type: text/x-diff, Size: 8264 bytes --]

From 330c1c38cb1bf57b631aa1311eb89d8e0fad4bf4 Mon Sep 17 00:00:00 2001
From: Eric Bavier <bavier@member.fsf.org>
Date: Mon, 14 Jul 2014 23:42:57 -0500
Subject: [PATCH] guix: refresh: Add --list-upstream-closure option.

* guix/utils.scm (fold-forest, fold-forest-leaves): New functions.
* guix/scripts/refresh.scm (upstream-packages): New functions.
  (%options, show-help, guix-refresh): Add --list-upstream-closure option.
---
 guix/scripts/refresh.scm |   96 +++++++++++++++++++++++++++++++++-------------
 guix/utils.scm           |   30 +++++++++++++++
 2 files changed, 100 insertions(+), 26 deletions(-)

diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index c65a7d0..d34bbb3 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -59,6 +59,9 @@
                     (x
                      (leave (_ "~a: invalid selection; expected `core' or `non-core'")
                             arg)))))
+        (option '(#\l "list-upstream-closure") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'list-upstream? #t result)))
 
         (option '("key-server") #t #f
                 (lambda (opt name arg result)
@@ -96,6 +99,10 @@ specified with `--select'.\n"))
   (display (_ "
   -s, --select=SUBSET    select all the packages in SUBSET, one of
                          `core' or `non-core'"))
+  (display (_ "
+  -l, --list-upstream-closure
+                         List top-level upstream 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"))
@@ -143,6 +150,36 @@ values: 'interactive' (default), 'always', and 'never'."
 downloaded and authenticated; not updating")
                    (package-name package) version)))))
 
+(define (upstream-packages packages)
+  "Return a minimal list of top-level package specifications for packages that
+should be built in order to test changes made to the packages in
+PACKAGE-SPECS.  Building the returned packages will ensure that *all* packages
+that depend, directly or indirectly, on those packages in PACKAGE-SPECS are
+tested."
+  (define (package-direct-inputs package)
+    (append (package-native-inputs package)
+            (package-inputs package)
+            (package-propagated-inputs package)))
+
+  (let ((inverse-package-dependency-graph
+         (fold-packages
+          (lambda (package forest)
+            (for-each
+             (lambda (d)
+               ;; Insert a tree edge from each of package's inputs to package.
+               (hash-set! forest d
+                          (cons package
+                                (hash-ref forest d '()))))
+             (map cadr (package-direct-inputs package)))
+            forest)
+          (make-hash-table))))
+    (map package-full-name
+         (fold-forest-leaves
+          cons '()
+          (lambda (node)
+            (hash-ref inverse-package-dependency-graph node '()))
+          packages))))
+
 
 \f
 ;;;
@@ -193,9 +230,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-upstream? (assoc-ref opts 'list-upstream?))
+         (key-download   (assoc-ref opts 'key-download))
          (packages
           (match (concatenate
                   (filter-map (match-lambda
@@ -220,26 +258,32 @@ 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-upstream?
+        (format (current-output-port)
+                (_ "The following packages would need rebuilding: ~{~a~^ ~}~%")
+                (upstream-packages 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..bdc5c1e 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -72,6 +72,8 @@
             call-with-temporary-output-file
             with-atomic-file-output
             fold2
+            fold-forest
+            fold-forest-leaves
 
             filtered-port
             compressed-port
@@ -649,6 +651,34 @@ output port, and PROC's result is returned."
              (lambda (result1 result2)
                (fold2 proc result1 result2 (cdr lst1) (cdr lst2)))))))))
 
+(define (fold-forest proc init next roots)
+  "Call (PROC NODE RESULT) for each node in the forest 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 (NEXT NODE), the result of which should be a list of nodes that are
+connected to NODE in the forest, or '() 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)
+                 (append tail (next head)))
+           (loop result seen tail))))))
+
+(define (fold-forest-leaves proc init next roots)
+  "Like fold-forest, but call (PROC NODE RESULT) only for leaf nodes."
+  (fold-forest
+   (lambda (node result)
+     (match (next node)
+       (() (proc node result))
+       (else result)))
+   init next roots))
+
 \f
 ;;;
 ;;; Source location.
-- 
1.7.9.5


[-- Attachment #3: Type: text/plain, Size: 17 bytes --]


-- 
Eric Bavier