From e509d1527d231b6460a20762e13b57cba2e43485 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sun, 20 Jan 2013 22:17:58 +0100
Subject: packages: Have `package-derivation' return a <derivation> as a second
 value.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

* guix/packages.scm (cache): Change the `drv' argument to `thunk'.
  Memoize all the return values of THUNK.
  (cached-derivation): Remove.
  (cached): New macro.
  (package-derivation): Use `cached' instead of `(or (cached-derivation) …)'.
* doc/guix.texi (Defining Packages): Update accordingly.
---
 guix/packages.scm | 89 +++++++++++++++++++++++++++++--------------------------
 1 file changed, 47 insertions(+), 42 deletions(-)

(limited to 'guix/packages.scm')

diff --git a/guix/packages.scm b/guix/packages.scm
index e65877df58..da8f45af5e 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -217,25 +217,34 @@ (define %derivation-cache
   ;; Package to derivation-path mapping.
   (make-weak-key-hash-table 100))
 
-(define (cache package system drv)
-  "Memoize DRV as the derivation of PACKAGE on 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 `((,system . ,drv)))
-  drv)
-
-(define (cached-derivation package system)
-  "Return the cached derivation path of PACKAGE for SYSTEM, or #f."
-  (match (hashq-ref %derivation-cache package)
-    ((alist ...)
-     (assoc-ref alist system))
-    (#f #f)))
+(define (cache package system thunk)
+  "Memoize the return values of THUNK as the derivation of PACKAGE on
+SYSTEM."
+  (let ((vals (call-with-values thunk list)))
+    ;; 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 `((,system ,@vals)))
+    (apply values vals)))
+
+(define-syntax-rule (cached package system body ...)
+  "Memoize the result of BODY for the arguments PACKAGE and SYSTEM.
+Return the cached result when available."
+  (let ((thunk (lambda () body ...)))
+    (match (hashq-ref %derivation-cache package)
+      ((alist (... ...))
+       (match (assoc-ref alist system)
+         ((vals (... ...))
+          (apply values vals))
+         (#f
+          (cache package system thunk))))
+      (#f
+       (cache package system thunk)))))
 
 (define* (package-derivation store package
                              #:optional (system (%current-system)))
-  "Return the derivation of PACKAGE for SYSTEM."
+  "Return the derivation path and corresponding <derivation> object of
+PACKAGE for SYSTEM."
   (define (intern file)
     ;; Add FILE to the store.  Set the `recursive?' bit to #t, so that
     ;; file permissions are preserved.
@@ -281,32 +290,28 @@ (define expand-input
                          (package package)
                          (input   x)))))))
 
-  (or (cached-derivation package system)
-
-      ;; Compute the derivation and cache the result.  Caching is
-      ;; important because some derivations, such as the implicit inputs
-      ;; of the GNU build system, will be queried many, many times in a
-      ;; row.
-      (cache
-       package system
-       (match package
-         (($ <package> name version source (= build-system-builder builder)
-             args inputs propagated-inputs native-inputs self-native-input?
-             outputs)
-          ;; TODO: For `search-paths', add a builder prologue that calls
-          ;; `set-path-environment-variable'.
-          (let ((inputs (map expand-input
-                             (package-transitive-inputs package))))
-
-            (apply builder
-                   store (package-full-name package)
-                   (and source
-                        (package-source-derivation store source system))
-                   inputs
-                   #:outputs outputs #:system system
-                   (if (procedure? args)
-                       (args system)
-                       args))))))))
+  ;; Compute the derivation and cache the result.  Caching is important
+  ;; because some derivations, such as the implicit inputs of the GNU build
+  ;; system, will be queried many, many times in a row.
+  (cached package system
+          (match package
+            (($ <package> name version source (= build-system-builder builder)
+                args inputs propagated-inputs native-inputs self-native-input?
+                outputs)
+             ;; TODO: For `search-paths', add a builder prologue that calls
+             ;; `set-path-environment-variable'.
+             (let ((inputs (map expand-input
+                                (package-transitive-inputs package))))
+
+               (apply builder
+                      store (package-full-name package)
+                      (and source
+                           (package-source-derivation store source system))
+                      inputs
+                      #:outputs outputs #:system system
+                      (if (procedure? args)
+                          (args system)
+                          args)))))))
 
 (define* (package-cross-derivation store package)
   ;; TODO
-- 
cgit v1.2.3