packages: Generalize the 'cached' macro.origin/wip-grafts

* guix/packages.scm (cache): Rename to...
  (cache!): ... this.  Add 'cache' parameter, and use it.
  (cached): Add a rule to allow the cache to be specified.

1 files changed, 20 insertions, 17 deletions

diff --git a/guix/packages.scm b/guix/packages.scm
index 698a4c8097..058ea62081 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -580,8 +580,8 @@ supported by its dependencies."
   ;; Package to derivation-path mapping.
   (make-weak-key-hash-table 100))
 
-(define (cache package system thunk)
-  "Memoize the return values of THUNK as the derivation of PACKAGE on
+(define (cache! cache package system thunk)
+  "Memoize in CACHE the return values of THUNK as the derivation of PACKAGE on
 SYSTEM."
   ;; FIXME: This memoization should be associated with the open store, because
   ;; otherwise it breaks when switching to a different store.
@@ -589,26 +589,29 @@ SYSTEM."
     ;; Use `hashq-set!' instead of `hash-set!' because `hash' returns the
     ;; same value for all structs (as of Guile 2.0.6), and because pointer
     ;; equality is sufficient in practice.
-    (hashq-set! %derivation-cache package
+    (hashq-set! cache package
                 `((,system ,@vals)
-                  ,@(or (hashq-ref %derivation-cache package)
-                        '())))
+                  ,@(or (hashq-ref cache package) '())))
     (apply values vals)))
 
-(define-syntax-rule (cached package system body ...)
-  "Memoize the result of BODY for the arguments PACKAGE and SYSTEM.
+(define-syntax cached
+  (syntax-rules (=>)
+    "Memoize the result of BODY for the arguments PACKAGE and SYSTEM.
 Return the cached result when available."
-  (let ((thunk (lambda () body ...))
-        (key   system))
-    (match (hashq-ref %derivation-cache package)
-      ((alist (... ...))
-       (match (assoc-ref alist key)
-         ((vals (... ...))
-          (apply values vals))
+    ((_ (=> cache) package system body ...)
+     (let ((thunk (lambda () body ...))
+           (key   system))
+       (match (hashq-ref cache package)
+         ((alist (... ...))
+          (match (assoc-ref alist key)
+            ((vals (... ...))
+             (apply values vals))
+            (#f
+             (cache! cache package key thunk))))
          (#f
-          (cache package key thunk))))
-      (#f
-       (cache package key thunk)))))
+          (cache! cache package key thunk)))))
+    ((_ package system body ...)
+     (cached (=> %derivation-cache) package system body ...))))
 
 (define* (expand-input store package input system #:optional cross-system)
   "Expand INPUT, an input tuple, such that it contains only references to