From b333c77da7fb4dae4059d0acdddd5938128d0c2e Mon Sep 17 00:00:00 2001
From: zimoun <zimon.toutoune@gmail.com>
Date: Sun, 3 May 2020 17:01:53 +0200
Subject: DRAFT packages: Add new procedure 'fold-packages*'.

---
 gnu/packages.scm   | 47 +++++++++++++++++++++++++++++++++++++++++++++++
 guix/ui.scm        | 29 ++++++++++++++++++-----------
 tests/packages.scm | 31 +++++++++++++++++++++++++++++++
 3 files changed, 96 insertions(+), 11 deletions(-)

diff --git a/gnu/packages.scm b/gnu/packages.scm
index fa18f81487..a0c5835b8b 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -55,6 +55,7 @@
 
             fold-packages
             fold-available-packages
+            fold-packages*
 
             find-newest-available-packages
             find-packages-by-name
@@ -253,6 +254,52 @@ is guaranteed to never traverse the same package twice."
                                 init
                                 modules))
 
+(define (fold-packages* proc init)
+  "Fold (PROC PACKAGE RESULT) over the list of available packages.  When a
+package cache is available, this procedure does not actually load any package
+module.  Moreover when package cache is available, this procedure
+re-constructs a new package skipping some package record field.  The usage of
+this procedure is User Interface (ui) only."
+  (define cache
+    (load-package-cache (current-profile)))
+
+  (define license  (@@ (guix licenses) license))
+
+  (if (and cache (cache-is-authoritative?))
+      (vhash-fold (lambda (name vector result)
+                    (match vector
+                      (#(name version module symbol outputs
+                              supported? deprecated?
+                              file line column
+                              synopsis description home-page
+                              build-system-name build-system-description
+                              supported-systems direct-inputs
+                              license-name license-uri license-comment)
+                       (proc (package
+                               (name name)
+                               (version version)
+                               (source #f)            ;TODO: ?
+                               (build-system
+                                 (build-system
+                                   (name (string->symbol build-system-name))
+                                   (description build-system-description)
+                                   (lower #f)))       ; never used by ui
+                               (inputs ; list of "full-name@version"
+                                (list 'cache direct-inputs))
+                               (outputs outputs)
+                               (synopsis synopsis)
+                               (description description)
+                               (license (license
+                                         license-name license-uri license-comment))
+                               (home-page home-page)
+                               (supported-systems (list 'cache supported-systems))
+                               (location (location
+                                          file line column)))
+                        result))))
+                  init
+                  cache)
+      (fold-packages proc init)))
+
 (define %package-cache-file
   ;; Location of the package cache.
   "/lib/guix/package.cache")
diff --git a/guix/ui.scm b/guix/ui.scm
index ea5f460865..abc2ecaf99 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -1416,13 +1416,10 @@ HYPERLINKS? is true, emit hyperlink escape sequences when appropriate."
     ;; the initial "+ " prefix.
     (if (> width 2) (- width 2) width))
 
-  (define (dependencies->recutils packages)
-    (let ((list (string-join (delete-duplicates
-                              (map package-full-name
-                                   (sort packages package<?))) " ")))
-      (string->recutils
-       (fill-paragraph list width*
-                       (string-length "dependencies: ")))))
+  (define (dependencies->string packages)
+    (string-join (delete-duplicates
+                  (map package-full-name
+                       (sort packages package<?))) " "))
 
   (define (package<? p1 p2)
     (string<? (package-full-name p1) (package-full-name p2)))
@@ -1432,11 +1429,21 @@ HYPERLINKS? is true, emit hyperlink escape sequences when appropriate."
   (format port "version: ~a~%" (package-version p))
   (format port "outputs: ~a~%" (string-join (package-outputs p)))
   (format port "systems: ~a~%"
-          (string-join (package-transitive-supported-systems p)))
+          (match (package-supported-systems p)
+            (('cache supported-systems)
+             (string-join supported-systems))
+            (_
+             (string-join (package-transitive-supported-systems p)))))
   (format port "dependencies: ~a~%"
-          (match (package-direct-inputs p)
-            (((labels inputs . _) ...)
-             (dependencies->recutils (filter package? inputs)))))
+          (let ((dependencies
+                 (match (package-direct-inputs p)
+                    (('cache inputs)
+                     (string-join inputs))
+                    (((labels inputs . _) ...)
+                     (dependencies->string (filter package? inputs))))))
+            (string->recutils
+             (fill-paragraph dependencies width*
+                             (string-length "dependencies: ")))))
   (format port "location: ~a~%"
           (or (and=> (package-location p)
                      (if hyperlinks? location->hyperlink location->string))
diff --git a/tests/packages.scm b/tests/packages.scm
index 7a8b5e4a2d..4504f6cf33 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -1169,6 +1169,37 @@
     ((one)
      (eq? one guile-2.0))))
 
+(test-assert "fold-packages* hello with/without cache"
+  (let ()
+    (define (equal-package? p1 p2)
+      ;; fold-package* re-constructs a new package skipping 'source' and 'lower'
+      ;; so equal? does not apply
+      (and (equal? (package-full-name p1) (package-full-name p2))
+           (equal? (package-description p1) (package-description p2))))
+
+    (define no-cache
+      (fold-packages* (lambda (p r)
+                        (if (string=? (package-name p) "hello")
+                            p
+                            r))
+                      #f))
+
+    (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-packages* (lambda (p r)
+                                      (if (string=? (package-name p) "hello")
+                                          p
+                                          r))
+                                    #f))))))
+
+    (and (equal? no-cache hello)
+         (equal-package? from-cache hello)
+         (equal-package? no-cache from-cache))))
+
 (test-assert "fold-available-packages with/without cache"
   (let ()
     (define no-cache
-- 
cgit v1.2.3