2 files changed, 15 insertions(+), 15 deletions(-)

M guix/packages.scm
M tests/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)
                   (()

@@ 1243,12 1243,13 @@
             (parameterize ((%current-target-system #f))
               (bag-transitive-inputs bag)))))
 
-(test-assert "bag->derivation"
+(test-assertm "bag->derivation"
   (parameterize ((%graft? #f))
     (let ((bag (package->bag gnu-make))
           (drv (package-derivation %store gnu-make)))
       (parameterize ((%current-system "foox86-hurd")) ;should have no effect
-        (equal? drv (bag->derivation %store bag))))))
+        (mlet %store-monad ((bag-drv (bag->derivation bag)))
+          (return (equal? drv bag-drv)))))))
 
 (test-assert "bag->derivation, cross-compilation"
   (parameterize ((%graft? #f))


@@ 1257,7 1258,8 @@
            (drv    (package-cross-derivation %store gnu-make target)))
       (parameterize ((%current-system "foox86-hurd") ;should have no effect
                      (%current-target-system "foo64-linux-gnu"))
-        (equal? drv (bag->derivation %store bag))))))
+        (mlet %store-monad ((bag-drv (bag->derivation bag)))
+          (return (equal? drv bag-drv)))))))
 
 (when (or (not (network-reachable?)) (shebang-too-long?))
   (test-skip 1))