packages: Core procedures are written in monadic style.

This plays better with the functional object cache, which is no longer
lost across calls to procedures created by 'store-lift'.

* guix/packages.scm (input-graft, input-cross-graft): Remove 'store'
parameter.  Return a monadic procedure.
(bag-grafts): Remove 'store' parameter and turn into a monadic
procedure.
(graft-derivation*): New procedure.
(cached): Remove clause to match syntax without (=> CACHE).
(package-grafts): Define using 'store-lower'.
(package-grafts*): New procedure, from former 'package-grafts'.  Remove
'store' parameter and turn into a monadic procedure.
(package->derivation): Rewrite using 'mcached' and a monadic variant of
the former 'package-derivation' procedure.
(package->cross-derivation): Likewise.
(package-derivation, package-cross-derivation): Rewrite in terms of
'store-lower'.
(%graft-cache): Remove.

1 files changed, 136 insertions, 118 deletions

diff --git a/guix/packages.scm b/guix/packages.scm
index 1b2728f033..36e55c0a42 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1199,9 +1199,7 @@ Return the cached result when available."
             (#f (cache! cache package key thunk))
             (value value)))
          (#f
-          (cache! cache package key thunk)))))
-    ((_ package system body ...)
-     (cached (=> %derivation-cache) package system body ...))))
+          (cache! cache package key thunk)))))))
 
 (define* (expand-input package input #:key native?)
   "Expand INPUT, an input tuple, to a name/<gexp-input> tuple.  PACKAGE is
@@ -1277,45 +1275,51 @@ 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."
+  (with-monad %store-monad
+    (match-lambda*
+      (((? package? package) output)
+       (let ((replacement (package-replacement package)))
+         (if replacement
+             ;; 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)))
+                        (return (graft
+                                  (origin orig)
+                                  (origin-output output)
+                                  (replacement new)
+                                  (replacement-output output))))
+                      package 'graft output system)
+             (return #f))))
+      (_
+       (return #f)))))
 
-(define (input-graft store system)
-  "Return a procedure that, given a package with a replacement and an output name,
-returns a graft, and #f otherwise."
-  (match-lambda*
-    (((? package? package) output)
-     (let ((replacement (package-replacement package)))
-       (and replacement
-            (cached (=> %graft-cache) package (cons output system)
-                    (let ((orig (package-derivation store package system
-                                                    #:graft? #f))
-                          (new  (package-derivation store replacement system
-                                                    #:graft? #t)))
-                      (graft
-                        (origin orig)
-                        (origin-output output)
-                        (replacement new)
-                        (replacement-output output)))))))))
-
-(define (input-cross-graft store target system)
+(define (input-cross-graft target system)
   "Same as 'input-graft', but for cross-compilation inputs."
-  (match-lambda*
-    (((? package? package) output)
-     (let ((replacement (package-replacement package)))
-       (and replacement
-            (let ((orig (package-cross-derivation store package target system
-                                                  #:graft? #f))
-                  (new  (package-cross-derivation store replacement
-                                                  target system
-                                                  #:graft? #t)))
-              (graft
-                (origin orig)
-                (origin-output output)
-                (replacement new)
-                (replacement-output output))))))))
+  (with-monad %store-monad
+    (match-lambda*
+      (((? package? package) output)
+       (let ((replacement (package-replacement package)))
+         (if replacement
+             (mlet %store-monad ((orig (package->cross-derivation package
+                                                                  target system
+                                                                  #:graft? #f))
+                                 (new  (package->cross-derivation replacement
+                                                                  target system
+                                                                  #:graft? #t)))
+               (return (graft
+                         (origin orig)
+                         (origin-output output)
+                         (replacement new)
+                         (replacement-output output))))
+             (return #f))))
+      (_
+       (return #f)))))
 
 (define* (fold-bag-dependencies proc seed bag
                                 #:key (native? #t))
@@ -1350,7 +1354,7 @@ dependencies; otherwise, restrict to target dependencies."
       ((head . tail)
        (loop tail result visited)))))
 
-(define* (bag-grafts store bag)
+(define* (bag-grafts bag)
   "Return the list of grafts potentially applicable to BAG.  Potentially
 applicable grafts are collected by looking at direct or indirect dependencies
 of BAG that have a 'replacement'.  Whether a graft is actually applicable
@@ -1359,46 +1363,55 @@ to (see 'graft-derivation'.)"
   (define system (bag-system bag))
   (define target (bag-target bag))
 
-  (define native-grafts
-    (let ((->graft (input-graft store system)))
-      (parameterize ((%current-system system)
-                     (%current-target-system #f))
-        (fold-bag-dependencies (lambda (package output grafts)
-                                 (match (->graft package output)
-                                   (#f    grafts)
-                                   (graft (cons graft grafts))))
-                               '()
-                               bag))))
-
-  (define target-grafts
-    (if target
-        (let ((->graft (input-cross-graft store target system)))
+  (mlet %store-monad
+      ((native-grafts
+        (let ((->graft (input-graft system)))
           (parameterize ((%current-system system)
-                         (%current-target-system target))
+                         (%current-target-system #f))
             (fold-bag-dependencies (lambda (package output grafts)
-                                     (match (->graft package output)
-                                       (#f    grafts)
-                                       (graft (cons graft grafts))))
-                                   '()
-                                   bag
-                                   #:native? #f)))
-        '()))
-
-  ;; We can end up with several identical grafts if we stumble upon packages
-  ;; that are not 'eq?' but map to the same derivation (this can happen when
-  ;; using things like 'package-with-explicit-inputs'.)  Hence the
-  ;; 'delete-duplicates' call.
-  (delete-duplicates
-   (append native-grafts target-grafts)))
-
-(define* (package-grafts store package
-                         #:optional (system (%current-system))
-                         #:key target)
+                                     (mlet %store-monad ((grafts grafts))
+                                       (>>= (->graft package output)
+                                            (match-lambda
+                                              (#f    (return grafts))
+                                              (graft (return (cons graft grafts)))))))
+                                   (return '())
+                                   bag))))
+
+       (target-grafts
+        (if target
+            (let ((->graft (input-cross-graft target system)))
+              (parameterize ((%current-system system)
+                             (%current-target-system target))
+                (fold-bag-dependencies
+                 (lambda (package output grafts)
+                   (mlet %store-monad ((grafts grafts))
+                     (>>= (->graft package output)
+                          (match-lambda
+                            (#f    (return grafts))
+                            (graft (return (cons graft grafts)))))))
+                 (return '())
+                 bag
+                 #:native? #f)))
+            (return '()))))
+
+    ;; We can end up with several identical grafts if we stumble upon packages
+    ;; that are not 'eq?' but map to the same derivation (this can happen when
+    ;; using things like 'package-with-explicit-inputs'.)  Hence the
+    ;; 'delete-duplicates' call.
+    (return (delete-duplicates
+             (append native-grafts target-grafts)))))
+
+(define* (package-grafts* package
+                          #:optional (system (%current-system))
+                          #:key target)
   "Return the list of grafts applicable to PACKAGE as built for SYSTEM and
 TARGET."
   (let* ((package (or (package-replacement package) package))
          (bag     (package->bag package system target)))
-    (bag-grafts store bag)))
+    (bag-grafts bag)))
+
+(define package-grafts
+  (store-lower package-grafts*))
 
 (define-inlinable (derivation=? drv1 drv2)
   "Return true if DRV1 and DRV2 are equal."
@@ -1438,7 +1451,6 @@ error reporting."
         ;; It's possible that INPUTS contains packages that are not 'eq?' but
         ;; that lead to the same derivation.  Delete those duplicates to avoid
         ;; issues down the road, such as duplicate entries in '%build-inputs'.
-        ;; TODO: Change to monadic style.
         (apply (bag-build bag) (bag-name bag)
                (delete-duplicates input-drvs input=?)
                #:search-paths paths
@@ -1488,51 +1500,57 @@ This is an internal procedure."
 (define bag->derivation*
   (store-lower bag->derivation))
 
-(define* (package-derivation store package
-                             #:optional (system (%current-system))
-                             #:key (graft? (%graft?)))
+(define graft-derivation*
+  (store-lift graft-derivation))
+
+(define* (package->derivation package
+                              #:optional (system (%current-system))
+                              #:key (graft? (%graft?)))
   "Return the <derivation> object of PACKAGE for 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.
-  (cached package (cons system graft?)
-          (let* ((bag (package->bag package system #f #:graft? graft?))
-                 (drv (bag->derivation* store bag package)))
-            (if graft?
-                (match (bag-grafts store bag)
-                  (()
-                   drv)
-                  (grafts
-                   (let ((guile (package-derivation store (guile-for-grafts)
-                                                    system #:graft? #f)))
-                     ;; TODO: As an optimization, we can simply graft the tip
-                     ;; of the derivation graph since 'graft-derivation'
-                     ;; recurses anyway.
-                     (graft-derivation store drv grafts
-                                       #:system system
-                                       #:guile guile))))
-                drv))))
-
-(define* (package-cross-derivation store package target
-                                   #:optional (system (%current-system))
-                                   #:key (graft? (%graft?)))
+  (mcached (mlet* %store-monad ((bag -> (package->bag package system #f
+                                                      #:graft? graft?))
+                                (drv (bag->derivation bag package)))
+             (if graft?
+                 (>>= (bag-grafts bag)
+                      (match-lambda
+                        (()
+                         (return drv))
+                        (grafts
+                         (mlet %store-monad ((guile (package->derivation
+                                                     (default-guile)
+                                                     system #:graft? #f)))
+                           (graft-derivation* drv grafts
+                                              #:system system
+                                              #:guile guile)))))
+                 (return drv)))
+           package system #f graft?))
+
+(define* (package->cross-derivation package target
+                                    #:optional (system (%current-system))
+                                    #:key (graft? (%graft?)))
   "Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix
 system identifying string)."
-  (cached package (list system target graft?)
-          (let* ((bag (package->bag package system target #:graft? graft?))
-                 (drv (bag->derivation* store bag package)))
-            (if graft?
-                (match (bag-grafts store bag)
-                  (()
-                   drv)
-                  (grafts
-                   (graft-derivation store drv grafts
-                                     #:system system
-                                     #:guile
-                                     (package-derivation store (guile-for-grafts)
-                                                         system #:graft? #f))))
-                drv))))
+  (mcached (mlet* %store-monad ((bag -> (package->bag package system target
+                                                      #:graft? graft?))
+                                (drv (bag->derivation bag package)))
+             (if graft?
+                 (>>= (bag-grafts bag)
+                      (match-lambda
+                        (()
+                         (return drv))
+                        (grafts
+                         (mlet %store-monad ((guile (package->derivation
+                                                     (default-guile)
+                                                     system #:graft? #f)))
+                           (graft-derivation* drv grafts
+                                              #:system system
+                                              #:guile guile)))))
+                 (return drv)))
+           package system target graft?))
 
 (define* (package-output store package
                          #:optional (output "out") (system (%current-system)))
@@ -1580,11 +1598,11 @@ unless you know what you are doing."
                   out)
               store))))
 
-(define package->derivation
-  (store-lift package-derivation))
+(define package-derivation
+  (store-lower package->derivation))
 
-(define package->cross-derivation
-  (store-lift package-cross-derivation))
+(define package-cross-derivation
+  (store-lower package->cross-derivation))
 
 (define-gexp-compiler (package-compiler (package <package>) system target)
   ;; Compile PACKAGE to a derivation for SYSTEM, optionally cross-compiled for