04/06: squash! packages: Core procedures are written in monadic style.

[guix-commits]

civodul pushed a commit to branch wip-build-systems-gexp
in repository guix.

commit 02bdf5c8248b6eb2e3ef612d55da1851395808bd
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Fri Mar 5 11:18:18 2021 +0100

    squash! packages: Core procedures are written in monadic style.
    
    (%graft-cache): Remove.
---
 guix/packages.scm | 22 +++++++++-------------
 1 file changed, 9 insertions(+), 13 deletions(-)

diff --git a/guix/packages.scm b/guix/packages.scm
index 22e792e..54a33c6 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1277,11 +1277,6 @@ and return it."
                                  (&package-error
                                   (package package))))))))))))
 
-(define %graft-cache
-  ;; 'eq?' cache mapping package objects to a graft corresponding to their
-  ;; replacement package.
-  (make-weak-key-hash-table 200))
-
 (define (input-graft system)
   "Return a monadic procedure that, given a package with a graft, returns a
 graft, and #f otherwise."
@@ -1290,17 +1285,18 @@ graft, and #f otherwise."
       (((? package? package) output)
        (let ((replacement (package-replacement package)))
          (if replacement
-             (return
-              (cached (=> %graft-cache) package (cons output system)
-                      (mlet %store-monad ((orig (package->derivation package 
system
+             ;; XXX: We should use a separate cache instead of abusing the
+             ;; object cache.
+             (mcached (mlet %store-monad ((orig (package->derivation package 
system
                                                                      #:graft? 
#f))
                                           (new  (package->derivation 
replacement system
                                                                      #:graft? 
#t)))
-                        (graft
-                          (origin orig)
-                          (origin-output output)
-                          (replacement new)
-                          (replacement-output output)))))
+                        (return (graft
+                                  (origin orig)
+                                  (origin-output output)
+                                  (replacement new)
+                                  (replacement-output output))))
+                      package 'graft output system)
              (return #f))))
       (_
        (return #f)))))