diff options
author | Ludovic Courtès <ludo@gnu.org> | 2015-04-04 22:05:15 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2021-03-30 22:48:43 +0200 |
commit | ba41f87ec77a3ee1757fd79ea53c171593451c6f (patch) | |
tree | a3cb90825d3c7eb6dc0a9f260bfa8b9db3536906 /guix/packages.scm | |
parent | 7d873f194ca69d6096d28d7a224ab78e83e34fe1 (diff) |
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.
Diffstat (limited to 'guix/packages.scm')
-rw-r--r-- | guix/packages.scm | 22 |
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) (() |