[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
15/29: packages: Turn 'bag->derivation' into a monadic procedure.
From: |
guix-commits |
Subject: |
15/29: packages: Turn 'bag->derivation' into a monadic procedure. |
Date: |
Mon, 8 Mar 2021 06:24:52 -0500 (EST) |
civodul pushed a commit to branch wip-build-systems-gexp
in repository guix.
commit 756b3b9f05945e1384f7c33d451559a1d16662cf
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sat Apr 4 22:05:15 2015 +0200
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.
---
guix/packages.scm | 22 ++++++++++------------
tests/packages.scm | 8 +++++---
2 files changed, 15 insertions(+), 15 deletions(-)
diff --git a/guix/packages.scm b/guix/packages.scm
index 7c8ecc6..2b59cd8 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1413,13 +1413,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)
@@ -1435,15 +1434,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."
@@ -1473,9 +1470,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=?)
@@ -1485,6 +1480,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?)))
@@ -1495,7 +1493,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)
(()
@@ -1518,7 +1516,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 d1dab7d..f68b078 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))
- 11/29: gexp: Reduce allocations in 'gexp-attribute'., (continued)
- 11/29: gexp: Reduce allocations in 'gexp-attribute'., guix-commits, 2021/03/08
- 09/29: gexp: Micro-optimize 'gexp->sexp' and 'lower-inputs'., guix-commits, 2021/03/08
- 13/29: gexp: Optimize 'with-build-variables'., guix-commits, 2021/03/08
- 10/29: gexp: Reduce allocations while traversing lists., guix-commits, 2021/03/08
- 20/29: build-system: Use 'sexp->gexp' for plain sexps., guix-commits, 2021/03/08
- 21/29: build-system: Use 'input-tuples->gexp' and 'outputs->gexp'., guix-commits, 2021/03/08
- 02/29: store: Micro-optimize object cache lookup., guix-commits, 2021/03/08
- 28/29: grafts: Add 'without-grafting'., guix-commits, 2021/03/08
- 29/29: gexp: Allowed/disallowed references and graphs never refer to grafted inputs., guix-commits, 2021/03/08
- 14/29: build-system: Rewrite using gexps., guix-commits, 2021/03/08
- 15/29: packages: Turn 'bag->derivation' into a monadic procedure.,
guix-commits <=
- 16/29: packages: Simplify patch instantiation., guix-commits, 2021/03/08
- 25/29: tests: Refer to '%derivation-cache' in the right module., guix-commits, 2021/03/08
- 26/29: packages: 'expand-input' accepts any file-like object., guix-commits, 2021/03/08
- 17/29: packages: Core procedures are written in monadic style., guix-commits, 2021/03/08
- 19/29: gexp: Add 'sexp->gexp'., guix-commits, 2021/03/08
- 05/29: gexp: Micro-optimize sexp serialization., guix-commits, 2021/03/08
- 12/29: gexp: Add 'with-build-variables'., guix-commits, 2021/03/08
- 18/29: packages: Default origin 'patch-flags' is a gexp., guix-commits, 2021/03/08
- 22/29: gexp: Honor #:target in 'compiled-modules'., guix-commits, 2021/03/08
- 23/29: packages: '%standard-patch-inputs' is not influenced by '%current-target-system'., guix-commits, 2021/03/08