diff options
| -rw-r--r-- | guix/packages.scm | 61 |
1 files changed, 22 insertions, 39 deletions
diff --git a/guix/packages.scm b/guix/packages.scm index defde2478a..4bc4b017f4 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -28,6 +28,7 @@ #:use-module (guix base32) #:use-module (guix grafts) #:use-module (guix derivations) + #:use-module (guix memoization) #:use-module (guix build-system) #:use-module (guix search-paths) #:use-module (guix gexp) @@ -697,38 +698,19 @@ in INPUTS and their transitive propagated inputs." `(assoc-ref ,alist ,(label input))) (transitive-inputs inputs))) -(define-syntax define-memoized/v - (lambda (form) - "Define a memoized single-valued unary procedure with docstring. -The procedure argument is compared to cached keys using `eqv?'." - (syntax-case form () - ((_ (proc arg) docstring body body* ...) - (string? (syntax->datum #'docstring)) - #'(define proc - (let ((cache (make-hash-table))) - (define (proc arg) - docstring - (match (hashv-get-handle cache arg) - ((_ . value) - value) - (_ - (let ((result (let () body body* ...))) - (hashv-set! cache arg result) - result)))) - proc)))))) - -(define-memoized/v (package-transitive-supported-systems package) - "Return the intersection of the systems supported by PACKAGE and those +(define package-transitive-supported-systems + (mlambdaq (package) + "Return the intersection of the systems supported by PACKAGE and those supported by its dependencies." - (fold (lambda (input systems) - (match input - ((label (? package? p) . _) - (lset-intersection - string=? systems (package-transitive-supported-systems p))) - (_ - systems))) - (package-supported-systems package) - (bag-direct-inputs (package->bag package)))) + (fold (lambda (input systems) + (match input + ((label (? package? p) . _) + (lset-intersection + string=? systems (package-transitive-supported-systems p))) + (_ + systems))) + (package-supported-systems package) + (bag-direct-inputs (package->bag package))))) (define* (supported-package? package #:optional (system (%current-system))) "Return true if PACKAGE is supported on SYSTEM--i.e., if PACKAGE and all its @@ -775,14 +757,15 @@ package and returns its new name after rewrite." (_ input))) - (define-memoized/v (replace p) - "Return a variant of P with its inputs rewritten." - (package - (inherit p) - (name (rewrite-name (package-name p))) - (inputs (map rewrite (package-inputs p))) - (native-inputs (map rewrite (package-native-inputs p))) - (propagated-inputs (map rewrite (package-propagated-inputs p))))) + (define replace + (mlambdaq (p) + ;; Return a variant of P with its inputs rewritten. + (package + (inherit p) + (name (rewrite-name (package-name p))) + (inputs (map rewrite (package-inputs p))) + (native-inputs (map rewrite (package-native-inputs p))) + (propagated-inputs (map rewrite (package-propagated-inputs p)))))) replace) |