From ba41f87ec77a3ee1757fd79ea53c171593451c6f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sat, 4 Apr 2015 22:05:15 +0200
Subject: [PATCH] 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 6dc652fe7a..171eb0b347 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1420,13 +1420,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)
@@ -1442,15 +1441,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."
@@ -1480,9 +1477,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=?)
@@ -1492,6 +1487,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?)))
@@ -1502,7 +1500,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)
                   (()
@@ -1525,7 +1523,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 d1dab7d6a5..f68b078b55 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))