16/16: packages: Core procedures are written in monadic style.

[Ludovic Courtès]

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

commit 6ce5f33b866372bb97f950bd43e359df42850cd7
Author: Ludovic Courtès <address@hidden>
Date:   Wed Jun 28 21:57:16 2017 +0200

    packages: Core procedures are written in monadic style.
    
    This plays better with the functional object cache, which is no longer
    lost across calls to procedures created by 'store-lift'.
    
    * guix/packages.scm (input-graft, input-cross-graft): Remove 'store'
    parameter.  Return a monadic procedure.
    (bag-grafts): Remove 'store' parameter and turn into a monadic
    procedure.
    (graft-derivation*): New procedure.
    (cached): Remove clause to match syntax without (=> CACHE).
    (package-grafts): Define using 'store-lower'.
    (package-grafts*): New procedure, from former 'package-grafts'.  Remove
    'store' parameter and turn into a monadic procedure.
    (package->derivation): Rewrite using 'mcached' and a monadic variant of
    the former 'package-derivation' procedure.
    (package->cross-derivation): Likewise.
    (package-derivation, package-cross-derivation): Rewrite in terms of
    'store-lower'.
---
 guix/packages.scm | 234 +++++++++++++++++++++++++++++-------------------------
 1 file changed, 125 insertions(+), 109 deletions(-)

diff --git a/guix/packages.scm b/guix/packages.scm
index 36c5884..6bf8039 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -843,9 +843,7 @@ Return the cached result when available."
             (#f
              (cache! cache package key thunk))))
          (#f
-          (cache! cache package key thunk)))))
-    ((_ package system body ...)
-     (cached (=> %derivation-cache) package system body ...))))
+          (cache! cache package key thunk)))))))
 
 (define* (expand-input package input #:key native?)
   "Expand INPUT, an input tuple, to a name/<gexp-input> tuple.  PACKAGE is
@@ -925,40 +923,44 @@ and return it."
   ;; replacement package.
   (make-weak-key-hash-table 200))
 
-(define (input-graft store system)
-  "Return a procedure that, given a package with a graft, returns a graft, and
-#f otherwise."
-  (match-lambda
-    ((? package? package)
-     (let ((replacement (package-replacement package)))
-       (and replacement
-            (cached (=> %graft-cache) package system
-                    (let ((orig (package-derivation store package system
-                                                    #:graft? #f))
-                          (new  (package-derivation store replacement system
-                                                    #:graft? #t)))
-                      (graft
-                        (origin orig)
-                        (replacement new)))))))
-    (x
-     #f)))
+(define (input-graft system)
+  "Return a monadic procedure that, given a package with a graft, returns a
+graft, and #f otherwise."
+  (with-monad %store-monad
+    (match-lambda
+      ((? package? package)
+       (let ((replacement (package-replacement package)))
+         (if replacement
+             (mlet %store-monad ((orig (package->derivation package system
+                                                            #:graft? #f))
+                                 (new  (package->derivation replacement system
+                                                            #:graft? #t)))
+               (return (graft
+                         (origin orig)
+                         (replacement new))))
+             (return #f))))
+      (_
+       (return #f)))))
 
-(define (input-cross-graft store target system)
+(define (input-cross-graft target system)
   "Same as 'input-graft', but for cross-compilation inputs."
-  (match-lambda
-    ((? package? package)
-    (let ((replacement (package-replacement package)))
-      (and replacement
-           (let ((orig (package-cross-derivation store package target system
-                                                 #:graft? #f))
-                 (new  (package-cross-derivation store replacement
-                                                 target system
-                                                 #:graft? #t)))
-             (graft
-               (origin orig)
-               (replacement new))))))
-   (_
-    #f)))
+  (with-monad %store-monad
+    (match-lambda
+      ((? package? package)
+       (let ((replacement (package-replacement package)))
+         (if replacement
+             (mlet %store-monad ((orig (package->cross-derivation package
+                                                                  target system
+                                                                  #:graft? #f))
+                                 (new  (package->cross-derivation replacement
+                                                                  target system
+                                                                  #:graft? 
#t)))
+               (return (graft
+                         (origin orig)
+                         (replacement new))))
+             (return #f))))
+      (_
+       (return #f)))))
 
 (define* (fold-bag-dependencies proc seed bag
                                 #:key (native? #t))
@@ -994,7 +996,7 @@ dependencies; otherwise, restrict to target dependencies."
       ((head . tail)
        (loop tail result visited)))))
 
-(define* (bag-grafts store bag)
+(define* (bag-grafts bag)
   "Return the list of grafts potentially applicable to BAG.  Potentially
 applicable grafts are collected by looking at direct or indirect dependencies
 of BAG that have a 'replacement'.  Whether a graft is actually applicable
@@ -1003,42 +1005,50 @@ to (see 'graft-derivation'.)"
   (define system (bag-system bag))
   (define target (bag-target bag))
 
-  (define native-grafts
-    (let ((->graft (input-graft store system)))
-      (fold-bag-dependencies (lambda (package grafts)
-                               (match (->graft package)
-                                 (#f    grafts)
-                                 (graft (cons graft grafts))))
-                             '()
-                             bag)))
-
-  (define target-grafts
-    (if target
-        (let ((->graft (input-cross-graft store target system)))
+  (mlet %store-monad
+      ((native-grafts
+        (let ((->graft (input-graft system)))
           (fold-bag-dependencies (lambda (package grafts)
-                                   (match (->graft package)
-                                     (#f    grafts)
-                                     (graft (cons graft grafts))))
-                                 '()
-                                 bag
-                                 #:native? #f))
-        '()))
-
-  ;; We can end up with several identical grafts if we stumble upon packages
-  ;; that are not 'eq?' but map to the same derivation (this can happen when
-  ;; using things like 'package-with-explicit-inputs'.)  Hence the
-  ;; 'delete-duplicates' call.
-  (delete-duplicates
-   (append native-grafts target-grafts)))
-
-(define* (package-grafts store package
-                         #:optional (system (%current-system))
-                         #:key target)
+                                   (mlet %store-monad ((grafts grafts))
+                                     (>>= (->graft package)
+                                          (match-lambda
+                                            (#f    (return grafts))
+                                            (graft (return (cons graft 
grafts)))))))
+                                 (return '())
+                                 bag)))
+
+       (target-grafts
+        (if target
+            (let ((->graft (input-cross-graft target system)))
+              (fold-bag-dependencies (lambda (package grafts)
+                                       (mlet %store-monad ((grafts grafts))
+                                         (>>= (->graft package)
+                                              (match-lambda
+                                                (#f    grafts)
+                                                (graft (cons graft grafts))))))
+                                     (return '())
+                                     bag
+                                     #:native? #f))
+            (return '()))))
+
+    ;; We can end up with several identical grafts if we stumble upon packages
+    ;; that are not 'eq?' but map to the same derivation (this can happen when
+    ;; using things like 'package-with-explicit-inputs'.)  Hence the
+    ;; 'delete-duplicates' call.
+    (return (delete-duplicates
+             (append native-grafts target-grafts)))))
+
+(define* (package-grafts* package
+                          #:optional (system (%current-system))
+                          #:key target)
   "Return the list of grafts applicable to PACKAGE as built for SYSTEM and
 TARGET."
   (let* ((package (or (package-replacement package) package))
          (bag     (package->bag package system target)))
-    (bag-grafts store bag)))
+    (bag-grafts bag)))
+
+(define package-grafts
+  (store-lower package-grafts*))
 
 (define* (bag->derivation bag #:optional context)
   "Return the derivation to build BAG for SYSTEM.  Optionally, CONTEXT can be
@@ -1105,51 +1115,57 @@ This is an internal procedure."
 (define bag->derivation*
   (store-lower bag->derivation))
 
-(define* (package-derivation store package
-                             #:optional (system (%current-system))
-                             #:key (graft? (%graft?)))
+(define graft-derivation*
+  (store-lift graft-derivation))
+
+(define* (package->derivation package
+                              #:optional (system (%current-system))
+                              #:key (graft? (%graft?)))
   "Return the <derivation> object of PACKAGE for SYSTEM."
 
   ;; Compute the derivation and cache the result.  Caching is important
   ;; because some derivations, such as the implicit inputs of the GNU build
   ;; 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)))
-            (if graft?
-                (match (bag-grafts store bag)
-                  (()
-                   drv)
-                  (grafts
-                   (let ((guile (package-derivation store (default-guile)
-                                                    system #:graft? #f)))
-                     ;; TODO: As an optimization, we can simply graft the tip
-                     ;; of the derivation graph since 'graft-derivation'
-                     ;; recurses anyway.
-                     (graft-derivation store drv grafts
-                                       #:system system
-                                       #:guile guile))))
-                drv))))
-
-(define* (package-cross-derivation store package target
-                                   #:optional (system (%current-system))
-                                   #:key (graft? (%graft?)))
+  (mcached (mlet* %store-monad ((bag -> (package->bag package system #f
+                                                      #:graft? graft?))
+                                (drv (bag->derivation bag package)))
+             (if graft?
+                 (>>= (bag-grafts bag)
+                      (match-lambda
+                        (()
+                         (return drv))
+                        (grafts
+                         (mlet %store-monad ((guile (package->derivation
+                                                     (default-guile)
+                                                     system #:graft? #f)))
+                           (graft-derivation* drv grafts
+                                              #:system system
+                                              #:guile guile)))))
+                 (return drv)))
+           package system graft?))
+
+(define* (package->cross-derivation package target
+                                    #:optional (system (%current-system))
+                                    #:key (graft? (%graft?)))
   "Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix
 system identifying string)."
-  (cached package (list system target graft?)
-          (let* ((bag (package->bag package system target #:graft? graft?))
-                 (drv (bag->derivation* store bag package)))
-            (if graft?
-                (match (bag-grafts store bag)
-                  (()
-                   drv)
-                  (grafts
-                   (graft-derivation store drv grafts
-                                     #:system system
-                                     #:guile
-                                     (package-derivation store (default-guile)
-                                                         system #:graft? #f))))
-                drv))))
+  (mcached (mlet* %store-monad ((bag -> (package->bag package system target
+                                                      #:graft? graft?))
+                                (drv (bag->derivation bag package)))
+             (if graft?
+                 (>>= (bag-grafts bag)
+                      (match-lambda
+                        (()
+                         (return drv))
+                        (grafts
+                         (mlet %store-monad ((guile (package->derivation
+                                                     (default-guile)
+                                                     system #:graft? #f)))
+                           (graft-derivation* drv grafts
+                                              #:system system
+                                              #:guile guile)))))
+                 (return drv)))
+           package system target graft?))
 
 (define* (package-output store package
                          #:optional (output "out") (system (%current-system)))
@@ -1193,11 +1209,11 @@ cross-compilation target triplet."
                   out)
               store))))
 
-(define package->derivation
-  (store-lift package-derivation))
+(define package-derivation
+  (store-lower package->derivation))
 
-(define package->cross-derivation
-  (store-lift package-cross-derivation))
+(define package-cross-derivation
+  (store-lower package->cross-derivation))
 
 (define-gexp-compiler (package-compiler (package <package>) system target)
   ;; Compile PACKAGE to a derivation for SYSTEM, optionally cross-compiled for