09/10: guix package: '--list-available' can use data from the cache.

[guix-commits]

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)