02/20: packages: Turn 'bag->derivation' into a monadic procedure.

[guix-commits]

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

commit ea7d584556e3698589243a66639cdb68f6cc6cdc
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 27072a3..747f844 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))