@@ -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")
@@ -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))
@@ -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