03/05: packages: Remove 'define-memoized/v' and use 'mlambdaq' instead.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit c9134e82fe0332787468dcd27f18bdc8609738fd
Author: Ludovic Courtès <address@hidden>
Date:   Sat Jan 28 17:15:27 2017 +0100

    packages: Remove 'define-memoized/v' and use 'mlambdaq' instead.
    
    * guix/packages.scm (define-memoized/v): Remove.
    (package-transitive-supported-systems): Use 'mlambdaq' instead of
    'define-memoized/v'.
    (package-input-rewriting)[replace]: Likewise.
---
 guix/packages.scm |   61 +++++++++++++++++++----------------------------------
 1 file changed, 22 insertions(+), 39 deletions(-)

diff --git a/guix/packages.scm b/guix/packages.scm
index defde24..4bc4b01 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)