packages: Turn 'bag->derivation' into a monadic procedure.

* guix/packages.scm (bag->derivation): Turn into a monadic procedure by
  remove 'store' parameter and removing the call to 'store-lower'.
  (bag->cross-derivation): Likewise.
  (bag->derivation*): New procedure.
  (package-derivation, package-cross-derivation): Use it instead of
  'bag->derivation'.
* tests/packages.scm ("bag->derivation"): Change to monadic style.
  ("bag->derivation, cross-compilation"): Likewise.

1 files changed, 10 insertions, 12 deletions

diff --git a/guix/packages.scm b/guix/packages.scm
index 6dc652fe7a..171eb0b347 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1420,13 +1420,12 @@ TARGET."
                       (derivation=? obj1 obj2))
                  (equal? obj1 obj2))))))))
 
-(define* (bag->derivation store bag
-                          #:optional context)
+(define* (bag->derivation bag #:optional context)
   "Return the derivation to build BAG for SYSTEM.  Optionally, CONTEXT can be
 a package object describing the context in which the call occurs, for improved
 error reporting."
   (if (bag-target bag)
-      (bag->cross-derivation store bag)
+      (bag->cross-derivation bag)
       (let* ((system     (bag-system bag))
              (inputs     (bag-transitive-inputs bag))
              (input-drvs (map (cut expand-input context <> #:native? #t)
@@ -1442,15 +1441,13 @@ error reporting."
         ;; 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 (store-lower (bag-build bag))
-               store (bag-name bag)
+        (apply (bag-build bag) (bag-name bag)
                (delete-duplicates input-drvs input=?)
                #:search-paths paths
                #:outputs (bag-outputs bag) #:system system
                (bag-arguments bag)))))
 
-(define* (bag->cross-derivation store bag
-                                #:optional context)
+(define* (bag->cross-derivation bag #:optional context)
   "Return the derivation to build BAG, which is actually a cross build.
 Optionally, CONTEXT can be a package object denoting the context of the call.
 This is an internal procedure."
@@ -1480,9 +1477,7 @@ This is an internal procedure."
                                     (_ '()))
                                    all))))
 
-    ;; TODO: Change to monadic style.
-    (apply (store-lower (bag-build bag))
-           store (bag-name bag)
+    (apply (bag-build bag) (bag-name bag)
            #:build-inputs (delete-duplicates build-drvs input=?)
            #:host-inputs (delete-duplicates host-drvs input=?)
            #:target-inputs (delete-duplicates target-drvs input=?)
@@ -1492,6 +1487,9 @@ This is an internal procedure."
            #:system system #:target target
            (bag-arguments bag))))
 
+(define bag->derivation*
+  (store-lower bag->derivation))
+
 (define* (package-derivation store package
                              #:optional (system (%current-system))
                              #:key (graft? (%graft?)))
@@ -1502,7 +1500,7 @@ This is an internal procedure."
   ;; 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)))
+                 (drv (bag->derivation* store bag package)))
             (if graft?
                 (match (bag-grafts store bag)
                   (()
@@ -1525,7 +1523,7 @@ This is an internal procedure."
 system identifying string)."
   (cached package (list system target graft?)
           (let* ((bag (package->bag package system target #:graft? graft?))
-                 (drv (bag->derivation store bag package)))
+                 (drv (bag->derivation* store bag package)))
             (if graft?
                 (match (bag-grafts store bag)
                   (()