civodul pushed a commit to branch wip-build-systems-gexp in repository guix.
commit 8724e57fe9b8cdd78d1d047aec0bed6d1ef7f812 Author: Ludovic Courtès <l...@gnu.org> 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))