From mboxrd@z Thu Jan 1 00:00:00 1970 From: Eric Bavier Subject: [PATCH] guix: refresh: Add --list-dependent option. Date: Thu, 17 Jul 2014 12:51:56 -0500 Message-ID: <874myf50w3.fsf@member.fsf.org> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:45729) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1X7pq8-000433-Oc for guix-devel@gnu.org; Thu, 17 Jul 2014 13:51:37 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1X7pq4-0001da-Cj for guix-devel@gnu.org; Thu, 17 Jul 2014 13:51:32 -0400 Received: from mail-ie0-x22b.google.com ([2607:f8b0:4001:c03::22b]:63168) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1X7pq4-0001dV-3V for guix-devel@gnu.org; Thu, 17 Jul 2014 13:51:28 -0400 Received: by mail-ie0-f171.google.com with SMTP id at1so3447075iec.16 for ; Thu, 17 Jul 2014 10:51:27 -0700 (PDT) Received: from cooper.gmail.com (chippewa-nat.cray.com. [136.162.34.1]) by mx.google.com with ESMTPSA id lo3sm8412524igb.22.2014.07.17.10.51.26 for (version=TLSv1.2 cipher=RC4-SHA bits=128/128); Thu, 17 Jul 2014 10:51:26 -0700 (PDT) List-Id: "Development of GNU Guix and the GNU System distribution." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org Sender: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org To: guix-devel@gnu.org --=-=-= Comments or suggestions welcome, in particular regarding the format of the output. --=-=-= Content-Type: text/x-diff; charset=utf-8 Content-Disposition: inline; filename=0001-guix-refresh-Add-list-dependent-option.patch Content-Transfer-Encoding: 8bit >From 57aa3ac9bf0a58c0981fbf729dd12756dedd5831 Mon Sep 17 00:00:00 2001 From: Eric Bavier 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 ;;; Copyright © 2013 Mark H Weaver +;;; Copyright © 2014 Eric Bavier ;;; ;;; 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 ;;; Copyright © 2013 Nikita Karetnikov +;;; Copyright © 2014 Eric Bavier ;;; ;;; 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 ;;; Copyright © 2013 Mark H Weaver +;;; Copyright © 2014 Eric Bavier ;;; ;;; 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 +;;; Copyright © 2014 Eric Bavier ;;; ;;; 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 --=-=-=--