06/06: DRAFT gexp: Turn grafting into a build continuation.

[Ludovic Courtès]

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

commit f2abcdfcdfa5dfbe52881cae2c7bc0bb5cf455ea
Author: Ludovic Courtès <address@hidden>
Date:   Mon Jan 9 23:20:25 2017 +0100

    DRAFT gexp: Turn grafting into a build continuation.
    
    TODO: See FIXME in gexp.scm.
    
    * guix/gexp.scm (gexp->derivation): Rename 'graft?' local variable to
    'prev-graft?' and call (set-grafting? #f) unconditionally.  When GRAFT?
    is true, call 'set-build-continuation' for DRV.
    * guix/grafts.scm (graft-derivation*, graft-continuation): New
    procedures.
    * tests/gexp.scm ("gexp-grafts"): Remove test that is now obsolete.
---
 guix/gexp.scm   |   81 ++++++++++++++++++++++++++++++++-----------------------
 guix/grafts.scm |   23 ++++++++++++++++
 tests/gexp.scm  |   19 -------------
 3 files changed, 71 insertions(+), 52 deletions(-)

diff --git a/guix/gexp.scm b/guix/gexp.scm
index b92f89b..891dcf0 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -189,6 +189,9 @@ Upon success, return the three argument procedure; 
otherwise return #f."
 corresponding to OBJ for SYSTEM, cross-compiling for TARGET if TARGET is true.
 OBJ must be an object that has an associated gexp compiler, such as a
 <package>."
+  ;; FIXME: Must register build continuation (or 'guix system build' does not
+  ;; graft its things because 'system-derivation' uses 'lower-object', not
+  ;; 'gexp->derivation'.)
   (let ((lower (lookup-compiler obj)))
     (lower obj system target)))
 
@@ -645,7 +648,7 @@ The other arguments are as for 'derivation'."
   (mlet* %store-monad (;; The following binding forces '%current-system' and
                        ;; '%current-target-system' to be looked up at >>=
                        ;; time.
-                       (graft?    (set-grafting graft?))
+                       (prev-graft? (set-grafting #f))
 
                        (system -> (or system (%current-system)))
                        (target -> (if (eq? target 'current)
@@ -690,38 +693,50 @@ The other arguments are as for 'derivation'."
                                                          #:system system
                                                          #:target target)
                                        (return #f)))
-                       (guile    (if guile-for-build
-                                     (return guile-for-build)
-                                     (default-guile-derivation system))))
-    (mbegin %store-monad
-      (set-grafting graft?)                       ;restore the initial setting
-      (raw-derivation name
-                      (string-append (derivation->output-path guile)
-                                     "/bin/guile")
-                      `("--no-auto-compile"
-                        ,@(if (pair? %modules)
-                              `("-L" ,(derivation->output-path modules)
-                                "-C" ,(derivation->output-path compiled))
-                              '())
-                        ,builder)
-                      #:outputs outputs
-                      #:env-vars env-vars
-                      #:system system
-                      #:inputs `((,guile)
-                                 (,builder)
-                                 ,@(if modules
-                                       `((,modules) (,compiled) ,@inputs)
-                                       inputs)
-                                 ,@(match graphs
-                                     (((_ . inputs) ...) inputs)
-                                     (_ '())))
-                      #:hash hash #:hash-algo hash-algo #:recursive? recursive?
-                      #:references-graphs (and=> graphs graphs-file-names)
-                      #:allowed-references allowed
-                      #:disallowed-references disallowed
-                      #:leaked-env-vars leaked-env-vars
-                      #:local-build? local-build?
-                      #:substitutable? substitutable?))))
+                       (guile      (if guile-for-build
+                                       (return guile-for-build)
+                                       (default-guile-derivation system))))
+    (>>= (mbegin %store-monad
+           (set-grafting prev-graft?)             ;restore the initial setting
+           (raw-derivation name
+                           (string-append (derivation->output-path guile)
+                                          "/bin/guile")
+                           `("--no-auto-compile"
+                             ,@(if (pair? %modules)
+                                   `("-L" ,(derivation->output-path modules)
+                                     "-C" ,(derivation->output-path compiled))
+                                   '())
+                             ,builder)
+                           #:outputs outputs
+                           #:env-vars env-vars
+                           #:system system
+                           #:inputs `((,guile)
+                                      (,builder)
+                                      ,@(if modules
+                                            `((,modules) (,compiled) ,@inputs)
+                                            inputs)
+                                      ,@(match graphs
+                                          (((_ . inputs) ...) inputs)
+                                          (_ '())))
+                           #:hash hash #:hash-algo hash-algo #:recursive? 
recursive?
+                           #:references-graphs (and=> graphs graphs-file-names)
+                           #:allowed-references allowed
+                           #:disallowed-references disallowed
+                           #:leaked-env-vars leaked-env-vars
+                           #:local-build? local-build?
+                           #:substitutable? substitutable?))
+         (if graft?
+             (lambda (drv)
+               ;; Register a build continuation to apply the relevant grafts
+               ;; to the outputs of DRV.
+               (mlet %store-monad ((grafts (gexp-grafts exp system
+                                                        #:target target)))
+                 (mbegin %store-monad
+                   (set-build-continuation (derivation-file-name drv)
+                                           (graft-continuation drv grafts))
+                   (return drv))))
+             (lambda (drv)
+               (with-monad %store-monad (return drv)))))))
 
 (define* (gexp-inputs exp #:key native?)
   "Return the input list for EXP.  When NATIVE? is true, return only native
diff --git a/guix/grafts.scm b/guix/grafts.scm
index 2006d39..da106ae 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -29,6 +29,7 @@
   #:use-module (srfi srfi-34)
   #:use-module (ice-9 match)
   #:use-module (ice-9 vlist)
+  #:use-module (ice-9 format)
   #:export (graft?
             graft
             graft-origin
@@ -39,6 +40,8 @@
             graft-derivation
             graft-derivation/shallow
 
+            graft-continuation
+
             %graft?
             set-grafting))
 
@@ -321,6 +324,26 @@ DRV itself to refer to those grafted dependencies."
          (graft-replacement first)
          drv))))
 
+(define graft-derivation*
+  (store-lift graft-derivation))
+
+(define (graft-continuation drv grafts)
+  "Return a monadic thunk that acts as a built continuation applying GRAFTS to
+the result of DRV."
+  (define _ gettext)                              ;FIXME: (guix ui)?
+  (match grafts
+    (()
+     (lift1 (const '()) %store-monad))
+    (x
+     (lambda (drv-file-name)
+       (format #t (_ "applying ~a grafts to~{ ~a~}~%")
+               (length grafts)
+               (match (derivation->output-paths drv)
+                 (((outputs . items) ...)
+                  items)))
+       (mlet  %store-monad ((drv (graft-derivation* drv grafts)))
+         (return (list (derivation-file-name drv))))))))
+
 
 ;; The following might feel more at home in (guix packages) but since (guix
 ;; gexp), which is a lower level, needs them, we put them here.
diff --git a/tests/gexp.scm b/tests/gexp.scm
index c9a77fd..1ead032 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -434,25 +434,6 @@
                  (equal? refs (list (dirname (dirname guile))))
                  (equal? refs2 (list file))))))
 
-(test-assertm "gexp->derivation vs. grafts"
-  (mlet* %store-monad ((graft?  (set-grafting #f))
-                       (p0 ->   (dummy-package "dummy"
-                                               (arguments
-                                                '(#:implicit-inputs? #f))))
-                       (r  ->   (package (inherit p0) (name "DuMMY")))
-                       (p1 ->   (package (inherit p0) (replacement r)))
-                       (exp0 -> (gexp (frob (ungexp p0) (ungexp output))))
-                       (exp1 -> (gexp (frob (ungexp p1) (ungexp output))))
-                       (void    (set-guile-for-build %bootstrap-guile))
-                       (drv0    (gexp->derivation "t" exp0 #:graft? #t))
-                       (drv1    (gexp->derivation "t" exp1 #:graft? #t))
-                       (drv1*   (gexp->derivation "t" exp1 #:graft? #f))
-                       (_       (set-grafting graft?)))
-    (return (and (not (string=? (derivation->output-path drv0)
-                                (derivation->output-path drv1)))
-                 (string=? (derivation->output-path drv0)
-                           (derivation->output-path drv1*))))))
-
 (test-assertm "gexp-grafts"
   ;; Make sure 'gexp-grafts' returns the graft to replace P1 by R.
   (let* ((p0    (dummy-package "dummy"