From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([209.51.188.92]:55600) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1gihza-0004y2-Ks for guix-patches@gnu.org; Sun, 13 Jan 2019 10:48:07 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1gihzZ-0004pQ-Gx for guix-patches@gnu.org; Sun, 13 Jan 2019 10:48:06 -0500 Received: from debbugs.gnu.org ([209.51.188.43]:58742) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1gihzZ-0004pI-DR for guix-patches@gnu.org; Sun, 13 Jan 2019 10:48:05 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1gihzZ-0008OO-BL for guix-patches@gnu.org; Sun, 13 Jan 2019 10:48:05 -0500 Subject: [bug#34060] [PATCH 09/10] guix package: '--list-available' can use data from the cache. Resent-Message-ID: From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Sun, 13 Jan 2019 16:47:32 +0100 Message-Id: <20190113154733.29737-9-ludo@gnu.org> In-Reply-To: <20190113154733.29737-1-ludo@gnu.org> References: <20190113154733.29737-1-ludo@gnu.org> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 34060@debbugs.gnu.org * gnu/packages.scm (fold-available-packages): New procedure. * guix/scripts/package.scm (process-query): Use it instead of 'fold-packages'. * tests/packages.scm ("fold-available-packages with/without cache"): New test. --- gnu/packages.scm | 45 ++++++++++++++++++++++++++++++++++++++++ guix/scripts/package.scm | 45 ++++++++++++++++++++++------------------ tests/packages.scm | 22 ++++++++++++++++++++ 3 files changed, 92 insertions(+), 20 deletions(-) diff --git a/gnu/packages.scm b/gnu/packages.scm index cf655e7448..a1814205f9 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -53,6 +53,7 @@ %default-package-module-path fold-packages + fold-available-packages find-packages-by-name find-package-locations @@ -182,6 +183,50 @@ flags." directory)) %load-path))) +(define (fold-available-packages proc init) + "Fold PROC over the list of available packages. For each available package, +PROC is called along these lines: + + (PROC NAME VERSION RESULT + #:outputs OUTPUTS + #:location LOCATION + …) + +PROC can use #:allow-other-keys to ignore the bits it's not interested in. +When a package cache is available, this procedure does not actually load any +package module." + (define cache + (load-package-cache (current-profile))) + + (if (and cache (cache-is-authoritative?)) + (vhash-fold (lambda (name vector result) + (match vector + (#(name version module symbol outputs + supported? deprecated? + file line column) + (proc name version result + #:outputs outputs + #:location (and file + (location file line column)) + #:supported? supported? + #:deprecated? deprecated?)))) + init + cache) + (fold-packages (lambda (package result) + (proc (package-name package) + (package-version package) + result + #:outputs (package-outputs package) + #:location (package-location package) + #:supported? + (->bool + (member (%current-system) + (package-supported-systems package))) + #:deprecated? + (->bool + (package-superseded package)))) + init))) + (define* (fold-packages proc init #:optional (modules (all-modules (%package-module-path) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 4f483ac141..e6f633b630 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -741,29 +741,34 @@ processed, #f otherwise." (('list-available regexp) (let* ((regexp (and regexp (make-regexp* regexp))) - (available (fold-packages - (lambda (p r) - (let ((n (package-name p))) - (if (and (supported-package? p) - (not (package-superseded p))) - (if regexp - (if (regexp-exec regexp n) - (cons p r) - r) - (cons p r)) - r))) + (available (fold-available-packages + (lambda* (name version result + #:key outputs location + supported? superseded? + #:allow-other-keys) + (if (and supported? (not superseded?)) + (if regexp + (if (regexp-exec regexp name) + (cons `(,name ,version + ,outputs ,location) + result) + result) + (cons `(,name ,version + ,outputs ,location) + result)) + result)) '()))) (leave-on-EPIPE - (for-each (lambda (p) - (format #t "~a\t~a\t~a\t~a~%" - (package-name p) - (package-version p) - (string-join (package-outputs p) ",") - (location->string (package-location p)))) + (for-each (match-lambda + ((name version outputs location) + (format #t "~a\t~a\t~a\t~a~%" + name version + (string-join outputs ",") + (location->string location)))) (sort available - (lambda (p1 p2) - (string))) #t) -- 2.20.1