From 0125e2d9a1564eb5e0817d50ea304bb4cb8d7030 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Mon, 20 Oct 2014 11:44:03 -0500 Subject: [PATCH] guix: refresh: Use bags. * guix/packages.scm (bag-direct-inputs): New procedure. * gnu/packages.scm (package-dependencies): Use it. (fold-packages*): New procedure. * guix/scripts/refresh.scm (guix-refresh)[list-dependent]: Use it. --- gnu/packages.scm | 19 +++++++-- guix/packages.scm | 11 +++-- guix/scripts/refresh.scm | 100 +++++++++++++++++++++++++++++----------------- 3 files changed, 87 insertions(+), 43 deletions(-) diff --git a/gnu/packages.scm b/gnu/packages.scm index 281d0d2..d3a064c 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -38,6 +38,7 @@ %package-module-path fold-packages + fold-packages* find-packages-by-name find-best-packages-by-name @@ -179,6 +180,18 @@ same package twice." vlist-null (all-package-modules)))) +(define (fold-packages* proc init) + "Call (PROC PACKAGE RESULT) for every defined package, including +module-private packages, using INIT as the initial value of RESULT. It is +guaranteed to never traverse the same package twice." + (fold-tree + proc init + (lambda (package) + (match (bag-direct-inputs (package->bag package)) + (((labels inputs . _) ...) + (filter package? inputs)))) + (fold-packages cons '()))) + (define find-packages-by-name (let ((packages (delay (fold-packages (lambda (p r) @@ -250,9 +263,9 @@ list of packages that depend on that package." (cons package (vhash-refq d in '())) (vhash-delq in d))) dag - (match (package-direct-inputs package) - (((labels packages . _) ...) - packages) ))) + (match (bag-direct-inputs (package->bag package)) + (((labels inputs . _) ...) + (filter package? inputs))))) vlist-null)))) (define (package-direct-dependents packages) diff --git a/guix/packages.scm b/guix/packages.scm index b397a24..4bf0a08 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -98,6 +98,7 @@ package->bag bag->derivation + bag-direct-inputs bag-transitive-inputs bag-transitive-host-inputs bag-transitive-build-inputs @@ -537,11 +538,15 @@ for the host system (\"native inputs\"), and not target inputs." recursively." (transitive-inputs (package-propagated-inputs package))) +(define (bag-direct-inputs bag) + "Same as 'package-direct-inputs', but applied to a bag." + (append (bag-build-inputs bag) + (bag-host-inputs bag) + (bag-target-inputs bag))) + (define (bag-transitive-inputs bag) "Same as 'package-transitive-inputs', but applied to a bag." - (transitive-inputs (append (bag-build-inputs bag) - (bag-host-inputs bag) - (bag-target-inputs bag)))) + (transitive-inputs (bag-direct-inputs bag))) (define (bag-transitive-build-inputs bag) "Same as 'package-transitive-native-inputs', but applied to a bag." diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index d31e6d4..1f878d8 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -182,6 +182,39 @@ downloaded and authenticated; not updating") (_ (cons package lst))))) + (define* (package-specs->packages specs #:key (include-private? #f)) + "Return a list of packages from the package specifications in SPECS. If +INCLUDE-PRIVATE? is #t, then also include module-private packages having the +same specification." + (let ((packages (map specification->package specs))) + (if include-private? + (fold-packages* + (let ((names (map package-full-name packages))) + (lambda (package result) + (if (find (cut string=? (package-full-name package) <>) + names) + (cons package result) + result))) + '()) + packages))) + + (define (select-newest-packages select?) + "Return a list of packages for which (SELECT? PACKAGE) return #t. If +multiple packages of the same name are selected, only the newest version is +returned." + (fold-packages (lambda (package result) + (if (select? package) + (keep-newest package result) + result)) + '())) + + (define (packages-from-specs-or-select specs select?) + "Return a list of packages from the package specifications in SPECS, or by +selecting the newest packages with SELECT?." + (match specs + (() (select-newest-packages select?)) + (specs (package-specs->packages specs)))) + (define core-package? (let* ((input->package (match-lambda ((name (? package? package) _ ...) package) @@ -206,33 +239,24 @@ update would trigger a complete rebuild." (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 - (('argument . value) - (let ((p (find-packages-by-name value))) - (when (null? p) - (leave (_ "~a: no package by that name~%") - value)) - p)) - (_ #f)) - opts)) - (() ; default to all packages - (let ((select? (match (assoc-ref opts 'select) - ('core core-package?) - ('non-core (negate core-package?)) - (_ (const #t))))) - (fold-packages (lambda (package result) - (if (select? package) - (keep-newest package result) - result)) - '()))) - (some ; user-specified packages - some)))) + (package-specs (filter-map (match-lambda + (('argument . value) value) + (_ #f)) + opts)) + (select? (match (assoc-ref opts 'select) + ('core core-package?) + ('non-core (negate core-package?)) + (_ (const #t))))) (with-error-handling (cond (list-dependent? - (let* ((rebuilds (map package-full-name + (let* ((packages (match package-specs + (() + (leave (_ "package arguments required~%"))) + (specs + (package-specs->packages + specs #:include-private? #t)))) + (rebuilds (map package-full-name (package-covering-dependents packages))) (total-dependents (length (package-transitive-dependents packages)))) @@ -252,7 +276,8 @@ dependent packages are rebuilt: ~{~a~^ ~}~%" (length rebuilds)) (length rebuilds) total-dependents rebuilds)))) (update? - (let ((store (open-connection))) + (let ((store (open-connection)) + (packages (packages-from-specs-or-select package-specs select?))) (parameterize ((%openpgp-key-server (or (assoc-ref opts 'key-server) (%openpgp-key-server))) @@ -263,15 +288,16 @@ dependent packages are rebuilt: ~{~a~^ ~}~%" (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)))))) + (let ((packages (packages-from-specs-or-select package-specs select?))) + (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))))))) -- 1.7.9.5