06/07: packages: Turn 'bag->derivation' into a monadic procedure.

[Ludovic Courtès]

civodul pushed a commit to branch wip-build-systems-gexp
in repository guix.

commit e207a495c7d69f9b465836d72921ae54587fd9b9
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 4375a45..da7afb0 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -873,13 +873,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
@@ -892,15 +891,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."
@@ -930,9 +926,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
@@ -941,6 +935,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?)))
@@ -951,7 +948,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)
                   (()
@@ -971,7 +968,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 f0af738..2848e53 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -631,12 +631,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))
@@ -645,7 +646,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))