diff options
| -rw-r--r-- | guix/packages.scm | 22 | ||||
| -rw-r--r-- | tests/packages.scm | 8 |
2 files changed, 15 insertions, 15 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) (() diff --git a/tests/packages.scm b/tests/packages.scm index d1dab7d6a5..f68b078b55 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -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)) |