diff options
| -rw-r--r-- | gnu/packages.scm | 47 | ||||
| -rw-r--r-- | guix/ui.scm | 29 | ||||
| -rw-r--r-- | 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 |