[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
05/11: packages: Turn 'bag->derivation' into a monadic procedure.
From: |
Ludovic Courtès |
Subject: |
05/11: packages: Turn 'bag->derivation' into a monadic procedure. |
Date: |
Sun, 25 Jun 2017 16:12:15 -0400 (EDT) |
civodul pushed a commit to branch wip-build-systems-gexp
in repository guix.
commit 619d4a3a474b883645f66c3245c84a51c8442e5a
Author: Ludovic Courtès <address@hidden>
Date: 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 | 23 ++++++++++-------------
tests/packages.scm | 8 +++++---
2 files changed, 15 insertions(+), 16 deletions(-)
diff --git a/guix/packages.scm b/guix/packages.scm
index 550ddf7..dc0ae0b 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1041,13 +1041,12 @@ TARGET."
(bag (package->bag package system target)))
(bag-grafts store bag)))
-(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))
(paths (delete-duplicates
@@ -1060,15 +1059,12 @@ error reporting."
(inputs (map (cut expand-input context <>)
inputs)))
- ;; TODO: Change to monadic style.
- (apply (store-lower (bag-build bag))
- store (bag-name bag) inputs
+ (apply (bag-build bag) (bag-name bag) inputs
#: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."
@@ -1098,9 +1094,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)
#:native-drvs build-drvs
#:target-drvs (append host-drvs target-drvs)
#:search-paths paths
@@ -1109,6 +1103,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?)))
@@ -1119,7 +1116,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)
(()
@@ -1142,7 +1139,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 9547d2f..23cbb73 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -856,12 +856,13 @@
(("dep" package)
(eq? package dep)))))
-(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))
@@ -870,7 +871,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))
- branch wip-build-systems-gexp created (now 0b64b8c), Ludovic Courtès, 2017/06/25
- 03/11: gexp: Micro-optimize sexp serialization., Ludovic Courtès, 2017/06/25
- 08/11: packages: Simplify patch instantiation., Ludovic Courtès, 2017/06/25
- 05/11: packages: Turn 'bag->derivation' into a monadic procedure.,
Ludovic Courtès <=
- 01/11: gnu: bootstrap: Move 'use-modules' forms to the beginning of build expressions., Ludovic Courtès, 2017/06/25
- 04/11: tests: Add 'test-assertm' to (guix tests)., Ludovic Courtès, 2017/06/25
- 09/11: Use 'mapm' instead of 'sequence' + 'map'., Ludovic Courtès, 2017/06/25
- 06/11: store: Add a functional object cache and use it in 'lower-object'., Ludovic Courtès, 2017/06/25
- 11/11: packages: Turn 'cache!' into a single-value-return cache., Ludovic Courtès, 2017/06/25
- 10/11: gexp: 'imported-files' takes file-like objects., Ludovic Courtès, 2017/06/25
- 07/11: DRAFT gexp: Handle list conversion to <gexp-input> in the expanded code., Ludovic Courtès, 2017/06/25
- 02/11: build-system: Rewrite using gexps., Ludovic Courtès, 2017/06/25