[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
09/10: guix package: '--list-available' can use data from the cache.
From: |
guix-commits |
Subject: |
09/10: guix package: '--list-available' can use data from the cache. |
Date: |
Tue, 15 Jan 2019 14:24:39 -0500 (EST) |
civodul pushed a commit to branch master
in repository guix.
commit 0ea939fb796fdd4f0d46d3534b2ec6135e0f3dc7
Author: Ludovic Courtès <address@hidden>
Date: Sun Jan 13 15:36:49 2019 +0100
guix package: '--list-available' can use data from the cache.
* 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 cf655e7..a181420 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 e9bed0b..a633d2e 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -736,29 +736,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<? (package-name p1)
- (package-name p2))))))
+ (match-lambda*
+ (((name1 . _) (name2 . _))
+ (string<? name1 name2))))))
#t))
(('search _)
diff --git a/tests/packages.scm b/tests/packages.scm
index 8aa117a..ed635d9 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -995,6 +995,28 @@
((one)
(eq? one guile-2.0))))
+(test-assert "fold-available-packages with/without cache"
+ (let ()
+ (define no-cache
+ (fold-available-packages (lambda* (name version result #:rest rest)
+ (cons (cons* name version rest)
+ result))
+ '()))
+
+ (define from-cache
+ (call-with-temporary-directory
+ (lambda (cache)
+ (generate-package-cache cache)
+ (mock ((guix describe) current-profile (const cache))
+ (mock ((gnu packages) cache-is-authoritative? (const #t))
+ (fold-available-packages (lambda* (name version result
+ #:rest rest)
+ (cons (cons* name version rest)
+ result))
+ '()))))))
+
+ (lset= equal? no-cache from-cache)))
+
(test-assert "find-packages-by-name"
(match (find-packages-by-name "hello")
(((? (cut eq? hello <>))) #t)
- branch master updated (b96909c -> b9da4b9), guix-commits, 2019/01/15
- 06/10: discovery: Add 'fold-module-public-variables*'., guix-commits, 2019/01/15
- 10/10: status: Distinguish 'package-cache' profile hook., guix-commits, 2019/01/15
- 05/10: inferior: Add 'gexp->derivation-in-inferior'., guix-commits, 2019/01/15
- 07/10: channels: Compute a package cache and use it., guix-commits, 2019/01/15
- 08/10: edit: Use 'specification->location' to read information from the cache., guix-commits, 2019/01/15
- 03/10: guix package: Avoid 'find-newest-available-packages'., guix-commits, 2019/01/15
- 01/10: gnu: Add gauche., guix-commits, 2019/01/15
- 09/10: guix package: '--list-available' can use data from the cache.,
guix-commits <=
- 02/10: profiling: Add a "gc" profiling component., guix-commits, 2019/01/15
- 04/10: packages: Remove 'find-newest-available-packages'., guix-commits, 2019/01/15