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/derivations.scm

@@ -989,15 +989,28 @@ recursively."
 ;;;
 
 (define* (build-derivations store derivations
-                            #:optional (mode (build-mode normal)))
+                            #:optional (mode (build-mode normal))
+                            #:key (continuations? #t))
   "Build DERIVATIONS, a list of <derivation> objects or .drv file names, using
-the specified MODE."
-  (build-things store (map (match-lambda
-                            ((? string? file) file)
-                            ((and drv ($ <derivation>))
-                             (derivation-file-name drv)))
-                           derivations)
-                mode))
+the specified MODE.  When CONTINUATIONS? is true, run the \"build
+continuations\" of each of DERIVATIONS.  Return the list of store items that
+were built."
+  (let ((things (build-things store (map (match-lambda
+                                           ((? string? file) file)
+                                           ((and drv ($ <derivation>))
+                                            (derivation-file-name drv)))
+                                         derivations)
+                              mode)))
+    ;; Convert the list of .drv file names to a list of output file names.
+    (append-map (match-lambda
+                  ((? derivation-path? drv)
+                   (let ((drv (call-with-input-file drv read-derivation)))
+                     (match (derivation->output-paths drv)
+                       (((outputs . items) ...)
+                        items))))
+                  (x
+                   (list x)))
+                things)))
 
 
 ;;;

guix/gexp.scm

@@ -34,6 +34,8 @@
             gexp-input
             gexp-input?
 
+            gexp-grafts
+
             local-file
             local-file?
             local-file-file
@@ -131,11 +133,12 @@
 
 ;; Compiler for a type of objects that may be introduced in a gexp.
 (define-record-type <gexp-compiler>
-  (gexp-compiler type lower expand)
+  (gexp-compiler type lower expand grafts)
   gexp-compiler?
-  (type       gexp-compiler-type)                 ;record type descriptor
+  (type       gexp-compiler-type)               ;record type descriptor
   (lower      gexp-compiler-lower)
-  (expand     gexp-compiler-expand))              ;#f | DRV -> sexp
+  (expand     gexp-compiler-expand)             ;DRV -> sexp
+  (grafts     gexp-compiler-applicable-grafts)) ;thing system target -> grafts
 
 (define %gexp-compilers
   ;; 'eq?' mapping of record type descriptor to <gexp-compiler>.
@@ -150,6 +153,18 @@ returns its output file name of OBJ's OUTPUT."
     ((? string? file)
      file)))
 
+(define (default-applicable-grafts thing system target)
+  "This is the default procedure returning applicable grafts for THING.  It
+returns the empty list---i.e., no grafts need to be applied."
+  (with-monad %store-monad
+    (return '())))
+
+(define (propagated-applicable-grafts field)
+  "Return a monadic procedure that propagates applicable grafts of the gexp
+returned by applying FIELD to the object."
+  (lambda (thing system target)
+    (gexp-grafts (field thing) #:target target)))
+
 (define (register-compiler! compiler)
   "Register COMPILER as a gexp compiler."
   (hashq-set! %gexp-compilers
@@ -167,6 +182,12 @@ procedure to expand it; otherwise return #f."
   (and=> (hashq-ref %gexp-compilers (struct-vtable object))
          gexp-compiler-expand))
 
+(define (lookup-graft-procedure object)
+  "Search for a procedure returning the list of applicable grafts for OBJECT.
+Upon success, return the three argument procedure; otherwise return #f."
+  (and=> (hashq-ref %gexp-compilers (struct-vtable object))
+         gexp-compiler-applicable-grafts))
+
 (define* (lower-object obj
                        #:optional (system (%current-system))
                        #:key target)
@@ -174,11 +195,14 @@ procedure to expand it; 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)))
 
 (define-syntax define-gexp-compiler
-  (syntax-rules (=> compiler expander)
+  (syntax-rules (=> compiler expander applicable-grafts)
     "Define NAME as a compiler for objects matching PREDICATE encountered in
 gexps.
 
@@ -188,21 +212,32 @@ object that matches PREDICATE, for SYSTEM and TARGET (the latter of which is
 
 The more elaborate form allows you to specify an expander:
 
-  (define-gexp-compiler something something?
+  (define-gexp-compiler something-compiler <something>
     compiler => (lambda (param system target) ...)
-    expander => (lambda (param drv output) ...))
+    expander => (lambda (param drv output) ...)
+    applicable-grafts => (lambda (param system target) ...))
 
-The expander specifies how an object is converted to its sexp representation."
+The expander specifies how an object is converted to its sexp representation.
+The 'applicable-grafts' monadic procedure returns a list of grafts that can be
+applied to the object."
     ((_ (name (param record-type) system target) body ...)
      (define-gexp-compiler name record-type
        compiler => (lambda (param system target) body ...)
-       expander => default-expander))
+       applicable-grafts => default-applicable-grafts))
     ((_ name record-type
         compiler => compile
-        expander => expand)
+        applicable-grafts => grafts)
+     (define-gexp-compiler name record-type
+       compiler => compile
+       expander => default-expander
+       applicable-grafts => grafts))
+    ((_ name record-type
+        compiler => compile
+        expander => expand
+        applicable-grafts => grafts)
      (begin
        (define name
-         (gexp-compiler record-type compile expand))
+         (gexp-compiler record-type compile expand grafts))
        (register-compiler! name)))))
 
 (define-gexp-compiler (derivation-compiler (drv <derivation>) system target)
@@ -320,13 +355,14 @@ to 'gexp->derivation'.
 This is the declarative counterpart of 'gexp->derivation'."
   (%computed-file name gexp options))
 
-(define-gexp-compiler (computed-file-compiler (file <computed-file>)
-                                              system target)
-  ;; Compile FILE by returning a derivation whose build expression is its
-  ;; gexp.
-  (match file
-    (($ <computed-file> name gexp options)
-     (apply gexp->derivation name gexp options))))
+(define-gexp-compiler computed-file-compiler <computed-file>
+  compiler => (lambda (file system target)
+                ;; Compile FILE by returning a derivation whose build
+                ;; expression is its gexp.
+                (match file
+                  (($ <computed-file> name gexp options)
+                   (apply gexp->derivation name gexp options))))
+  applicable-grafts => (propagated-applicable-grafts computed-file-gexp))
 
 (define-record-type <program-file>
   (%program-file name gexp guile)
@@ -342,13 +378,15 @@ GEXP.  GUILE is the Guile package used to execute that script.
 This is the declarative counterpart of 'gexp->script'."
   (%program-file name gexp guile))
 
-(define-gexp-compiler (program-file-compiler (file <program-file>)
-                                             system target)
-  ;; Compile FILE by returning a derivation that builds the script.
-  (match file
-    (($ <program-file> name gexp guile)
-     (gexp->script name gexp
-                   #:guile (or guile (default-guile))))))
+(define-gexp-compiler program-file-compiler <program-file>
+  compiler => (lambda (file system target)
+                ;; Compile FILE by returning a derivation that builds the
+                ;; script.
+                (match file
+                  (($ <program-file> name gexp guile)
+                   (gexp->script name gexp
+                                 #:guile (or guile (default-guile))))))
+  applicable-grafts => (propagated-applicable-grafts program-file-gexp))
 
 (define-record-type <scheme-file>
   (%scheme-file name gexp)
@@ -362,12 +400,14 @@ This is the declarative counterpart of 'gexp->script'."
 This is the declarative counterpart of 'gexp->file'."
   (%scheme-file name gexp))
 
-(define-gexp-compiler (scheme-file-compiler (file <scheme-file>)
-                                            system target)
-  ;; Compile FILE by returning a derivation that builds the file.
-  (match file
-    (($ <scheme-file> name gexp)
-     (gexp->file name gexp))))
+(define-gexp-compiler scheme-file-compiler <scheme-file>
+  compiler => (lambda (file system target)
+                ;; Compile FILE by returning a derivation that builds the
+                ;; file.
+                (match file
+                  (($ <scheme-file> name gexp)
+                   (gexp->file name gexp))))
+  applicable-grafts => (propagated-applicable-grafts scheme-file-gexp))
 
 ;; Appending SUFFIX to BASE's output file name.
 (define-record-type <file-append>
@@ -391,7 +431,12 @@ SUFFIX."
                   (($ <file-append> base suffix)
                    (let* ((expand (lookup-expander base))
                           (base   (expand base lowered output)))
-                     (string-append base (string-concatenate suffix)))))))
+                     (string-append base (string-concatenate suffix))))))
+  applicable-grafts => (lambda (obj system target)
+                         (match obj
+                           (($ <file-append> base _)
+                            (let ((proc (lookup-graft-procedure base)))
+                              (proc base system target))))))
 
 
 ;;;
@@ -510,6 +555,41 @@ names and file names suitable for the #:allowed-references argument to
     (lambda (system)
       ((force proc) system))))
 
+(define* (gexp-grafts exp
+                      #:optional (system (%current-system))
+                      #:key target)
+  "Return the list of grafts applicable to a derivation built by EXP, a gexp,
+for SYSTEM and TARGET (the latter is #f when building natively).
+
+This works by querying the list applicable grafts of each object EXP
+references---e.g., packages."
+  (with-monad %store-monad
+    (define gexp-input-grafts
+      (match-lambda
+        (($ <gexp-input> (? gexp? exp) _ #t)
+         (gexp-grafts exp system #:target #f))
+        (($ <gexp-input> (? gexp? exp) _ #f)
+         (gexp-grafts exp system #:target target))
+        (($ <gexp-input> (? struct? obj) _ #t)
+         (let ((applicable-grafts (lookup-graft-procedure obj)))
+          (applicable-grafts obj system #f)))
+        (($ <gexp-input> (? struct? obj) _ #f)
+         (let ((applicable-grafts (lookup-graft-procedure obj)))
+          (applicable-grafts obj system target)))
+        (($ <gexp-input> (lst ...) _ native?)
+         (foldm %store-monad
+                (lambda (input grafts)
+                  (mlet %store-monad ((g (gexp-input-grafts input)))
+                    (return (append g grafts))))
+                '()
+                lst))
+        (_                            ;another <gexp-input> or a <gexp-output>
+         (return '()))))
+
+    (>>= (mapm %store-monad gexp-input-grafts (gexp-references exp))
+         (lift1 (compose delete-duplicates concatenate)
+                %store-monad))))
+
 (define* (gexp->derivation name exp
                            #:key
                            system (target 'current)
@@ -579,7 +659,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)
@@ -624,38 +704,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

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.

guix/packages.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014, 2015 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
 ;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
@@ -909,6 +909,30 @@ and return it."
   ;; replacement package.
   (make-weak-key-hash-table 200))
 
+(define (replacement-graft store package system)
+  "Return the graft for SYSTEM to replace PACKAGE by its 'replacement'."
+  (cached (=> %graft-cache) package system
+          (let ((orig (package-derivation store package system
+                                          #:graft? #f))
+                (new  (package-derivation store (package-replacement package)
+                                          system
+                                          #:graft? #t)))
+            (graft
+              (origin orig)
+              (replacement new)))))
+
+(define* (replacement-cross-graft store package system target)
+  "Return the graft to replace PACKAGE by its 'replacement' when
+cross-compiling from SYSTEM to TARGET."
+  (let ((orig (package-cross-derivation store package target system
+                                        #:graft? #f))
+        (new  (package-cross-derivation store (package-replacement package)
+                                        target system
+                                        #:graft? #t)))
+    (graft
+      (origin orig)
+      (replacement new))))
+
 (define (input-graft store system)
   "Return a procedure that, given a package with a graft, returns a graft, and
 #f otherwise."
@@ -916,14 +940,7 @@ and return it."
     ((? 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)))))))
+            (replacement-graft store package system))))
     (x
      #f)))
 
@@ -933,14 +950,7 @@ and return it."
     ((? 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))))))
+           (replacement-cross-graft store package system target))))
    (_
     #f)))
 
@@ -1184,12 +1194,39 @@ cross-compilation target triplet."
 (define package->cross-derivation
   (store-lift package-cross-derivation))
 
-(define-gexp-compiler (package-compiler (package <package>) system target)
-  ;; Compile PACKAGE to a derivation for SYSTEM, optionally cross-compiled for
-  ;; TARGET.  This is used when referring to a package from within a gexp.
-  (if target
-      (package->cross-derivation package target system)
-      (package->derivation package system)))
+(define replacement-graft*
+  (let ((native (store-lift replacement-graft))
+        (cross  (store-lift replacement-cross-graft)))
+    (lambda (package system target)
+      "Return, as a monadic value, the replacement graft for PACKAGE, assuming
+it has a replacement."
+      (if target
+          (cross package system target)
+          (native package system)))))
+
+(define-gexp-compiler package-compiler <package>
+  compiler
+  => (lambda (package system target)
+       ;; Compile PACKAGE to a derivation for SYSTEM, optionally
+       ;; cross-compiled for TARGET.  This is used when referring to a package
+       ;; from within a gexp.
+       (if target
+           (package->cross-derivation package target system)
+           (package->derivation package system)))
+
+  applicable-grafts
+  => (let ((bag-grafts* (store-lift bag-grafts)))
+       (lambda (package system target)
+         ;; Return the list of grafts that apply to things that reference
+         ;; PACKAGE.
+         (mlet* %store-monad ((bag ->  (package->bag package
+                                                     system target))
+                              (grafts  (bag-grafts* bag)))
+           (if (package-replacement package)
+               (mlet %store-monad ((repl (replacement-graft* package
+                                                             system target)))
+                 (return (cons repl grafts)))
+               (return grafts))))))
 
 (define* (origin->derivation origin
                              #:optional (system (%current-system)))

guix/profiles.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
@@ -1120,8 +1120,7 @@ that fails."
   (let* ((drv  (run-with-store store
                  (profile-derivation (manifest '())
                                      #:locales? #f)))
-         (prof (derivation->output-path drv "out")))
-    (build-derivations store (list drv))
+         (prof (build-derivations store (list drv))))
     (switch-symlinks generation prof)))
 
 (define (switch-to-generation profile number)

guix/scripts.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014 Deck Pickard <deck.r.pickard@gmail.com>
 ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
 ;;;
@@ -29,6 +29,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-37)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
   #:export (args-fold*
             parse-command-line
             maybe-build
@@ -90,7 +91,8 @@ parameter of 'args-fold'."
 (define* (maybe-build drvs
                       #:key dry-run? use-substitutes?)
   "Show what will/would be built, and actually build DRVS, unless DRY-RUN? is
-true."
+true.  Return #f when DRY-RUN? is true, and the list of store items actually
+built otherwise."
   (with-monad %store-monad
     (>>= (show-what-to-build* drvs
                               #:dry-run? dry-run?
@@ -112,12 +114,14 @@ Show what and how will/would be built."
            (strip-keyword-arguments '(#:dry-run?) build-options))
     (mlet %store-monad ((derivation (package->derivation
                                      package #:graft? (and (not dry-run?)
-                                                           grafting?))))
-      (mbegin %store-monad
-        (maybe-build (list derivation)
-                     #:use-substitutes? use-substitutes?
-                     #:dry-run? dry-run?)
-        (return (show-derivation-outputs derivation))))))
+                                                           grafting?)))
+                        (items      (maybe-build (list derivation)
+                                                 #:use-substitutes?
+                                                 use-substitutes?
+                                                 #:dry-run? dry-run?)))
+      (unless dry-run?
+        (format #t "~{~a~%~}" items))
+      (return (or dry-run? items)))))
 
 (define* (build-package-source package
                                #:key dry-run? (use-substitutes? #t)
@@ -129,11 +133,13 @@ Show what and how will/would be built."
            #:use-substitutes? use-substitutes?
            (strip-keyword-arguments '(#:dry-run?) build-options))
     (mlet %store-monad ((derivation (origin->derivation
-                                     (package-source package))))
-      (mbegin %store-monad
-        (maybe-build (list derivation)
-                     #:use-substitutes? use-substitutes?
-                     #:dry-run? dry-run?)
-        (return (show-derivation-outputs derivation))))))
+                                     (package-source package)))
+                        (items      (maybe-build (list derivation)
+                                                 #:use-substitutes?
+                                                 use-substitutes?
+                                                 #:dry-run? dry-run?)))
+      (unless dry-run?
+        (format #t "~{~a~%~}" items))
+      (return (or dry-run? items)))))
 
 ;;; scripts.scm ends here

guix/scripts/archive.scm

@@ -256,24 +256,24 @@ resulting archive to the standard output port."
                         #:use-substitutes? (assoc-ref opts 'substitutes?)
                         #:dry-run? (assoc-ref opts 'dry-run?))
 
-    (if (or (assoc-ref opts 'dry-run?)
-            (build-derivations store drv))
-        (match (assoc-ref opts 'format)
-          ("nar"
-           (export-paths store files (current-output-port)
-                         #:recursive? (assoc-ref opts 'export-recursive?)))
-          ("docker"
-           (match files
-             ((file)
-              (let ((system (assoc-ref opts 'system)))
-                (format #t "~a\n"
-                        (build-docker-image file #:system system))))
-             (_
-              ;; TODO: Remove this restriction.
-              (leave (_ "only a single item can be exported to Docker~%")))))
-          (format
-           (leave (_ "~a: unknown archive format~%") format)))
-        (leave (_ "unable to export the given packages~%")))))
+    (let ((files (if (assoc-ref opts 'dry-run?)
+                     files
+                     (build-derivations store drv))))
+      (match (assoc-ref opts 'format)
+        ("nar"
+         (export-paths store files (current-output-port)
+                       #:recursive? (assoc-ref opts 'export-recursive?)))
+        ("docker"
+         (match files
+           ((file)
+            (let ((system (assoc-ref opts 'system)))
+              (format #t "~a\n"
+                      (build-docker-image file #:system system))))
+           (_
+            ;; TODO: Remove this restriction.
+            (leave (_ "only a single item can be exported to Docker~%")))))
+        (format
+         (leave (_ "~a: unknown archive format~%") format))))))
 
 (define (generate-key-pair parameters)
   "Generate a key pair with PARAMETERS, a canonical sexp, and store it in the

guix/scripts/build.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -726,11 +726,7 @@ needed."
                              (map (compose list derivation-file-name) drv)
                              roots))
                   ((not (assoc-ref opts 'dry-run?))
-                   (and (build-derivations store drv mode)
-                        (for-each show-derivation-outputs drv)
-                        (for-each (cut register-root store <> <>)
-                                  (map (lambda (drv)
-                                         (map cdr
-                                              (derivation->output-paths drv)))
-                                       drv)
-                                  roots))))))))))
+                   (let ((outputs (build-derivations store drv mode)))
+                     (format #t "~{~a~%~}" outputs)
+                     (for-each (cut register-root store <> <>)
+                               outputs roots))))))))))

guix/scripts/copy.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -112,14 +112,15 @@ package names, build the underlying packages before sending them."
                           #:use-substitutes? (assoc-ref opts 'substitutes?)
                           #:dry-run? (assoc-ref opts 'dry-run?))
 
-      (and (or (assoc-ref opts 'dry-run?)
-               (build-derivations local drv))
-           (let* ((session (open-ssh-session host #:user user #:port port))
-                  (sent    (send-files local items
-                                       (connect-to-remote-daemon session)
-                                       #:recursive? #t)))
-             (format #t "~{~a~%~}" sent)
-             sent)))))
+      (let ((items   (if (assoc-ref opts 'dry-run?)
+                         items
+                         (build-derivations local drv)))
+            (session (open-ssh-session host #:user user #:port port))
+            (sent    (send-files local items
+                                 (connect-to-remote-daemon session)
+                                 #:recursive? #t)))
+        (format #t "~{~a~%~}" sent)
+        sent))))
 
 (define (retrieve-from-remote-host source opts)
   "Retrieve ITEMS from SOURCE."

guix/scripts/package.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2013, 2015 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com>
@@ -207,19 +207,20 @@ specified in MANIFEST, a manifest object."
                         #:use-substitutes? use-substitutes?
                         #:dry-run? dry-run?)
 
-    (cond
-     (dry-run? #t)
-     ((and (file-exists? profile)
-           (and=> (readlink* profile) (cut string=? prof <>)))
-      (format (current-error-port) (_ "nothing to be done~%")))
-     (else
-      (let* ((number (generation-number profile))
+    (or dry-run?
+        (match (build-derivations store (list prof-drv))
+          ((prof)
+           (cond
+            ((and (file-exists? profile)
+                  (and=> (readlink* profile) (cut string=? prof <>)))
+             (format (current-error-port) (_ "nothing to be done~%")))
+            (else
+             (let* ((number (generation-number profile))
 
-             ;; Always use NUMBER + 1 for the new profile, possibly
-             ;; overwriting a "previous future generation".
-             (name   (generation-file-name profile (+ 1 number))))
-        (and (build-derivations store (list prof-drv))
-             (let* ((entries (manifest-entries manifest))
+                    ;; Always use NUMBER + 1 for the new profile, possibly
+                    ;; overwriting a "previous future generation".
+                    (name   (generation-file-name profile (+ 1 number)))
+                    (entries (manifest-entries manifest))
                     (count   (length entries)))
                (switch-symlinks name prof)
                (switch-symlinks profile name)
@@ -230,7 +231,7 @@ specified in MANIFEST, a manifest object."
                               count)
                        count)
                (display-search-paths entries (list profile)
-                                     #:kind 'prefix))))))))
+                                     #:kind 'prefix)))))))))
 
 
 ;;;

guix/scripts/system.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
 ;;;
@@ -445,20 +445,21 @@ open connection to the store."
                                               entries
                                               #:old-entries old-entries))))
     (show-what-to-build store (list grub.cfg))
-    (build-derivations store (list grub.cfg))
+
     ;; This is basically the same as install-grub*, but for now we avoid
     ;; re-installing the GRUB boot loader itself onto a device, mainly because
     ;; we don't in general have access to the same version of the GRUB package
     ;; which was used when installing this other system generation.
-    (let* ((grub.cfg-path (derivation->output-path grub.cfg))
-           (gc-root (string-append %gc-roots-directory "/grub.cfg"))
-           (temp-gc-root (string-append gc-root ".new")))
-      (switch-symlinks temp-gc-root grub.cfg-path)
-      (unless (false-if-exception (install-grub-config grub.cfg-path "/"))
-        (delete-file temp-gc-root)
-        (leave (_ "failed to re-install GRUB configuration file: '~a'~%")
-               grub.cfg-path))
-      (rename-file temp-gc-root gc-root))))
+    (match (build-derivations store (list grub.cfg))
+      ((grub.cfg-path)
+       (let* ((gc-root (string-append %gc-roots-directory "/grub.cfg"))
+              (temp-gc-root (string-append gc-root ".new")))
+         (switch-symlinks temp-gc-root grub.cfg-path)
+         (unless (false-if-exception (install-grub-config grub.cfg-path "/"))
+           (delete-file temp-gc-root)
+           (leave (_ "failed to re-install GRUB configuration file: '~a'~%")
+                  grub.cfg-path))
+         (rename-file temp-gc-root gc-root))))))
 
 
 ;;;
@@ -630,17 +631,15 @@ building anything."
                           (list sys grub.cfg grub)
                           (list sys grub.cfg))
                       (list sys)))
-       (%         (if derivations-only?
-                      (return (for-each (compose println derivation-file-name)
-                                        drvs))
+       (results   (if derivations-only?
+                      (return (map derivation-file-name drvs))
                       (maybe-build drvs #:dry-run? dry-run?
                                    #:use-substitutes? use-substitutes?))))
 
     (if (or dry-run? derivations-only?)
         (return #f)
         (begin
-          (for-each (compose println derivation->output-path)
-                    drvs)
+          (for-each println results)
 
           ;; Make sure GRUB is accessible.
           (when grub?

guix/store.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -71,6 +71,8 @@
             add-to-store
             build-things
             build
+            set-build-continuation!
+            set-build-continuation
             query-failed-paths
             clear-failed-paths
             add-temp-root
@@ -312,12 +314,16 @@
 
 (define-record-type <nix-server>
   (%make-nix-server socket major minor
-                    ats-cache atts-cache)
+                    continuations ats-cache atts-cache)
   nix-server?
   (socket nix-server-socket)
   (major  nix-server-major-version)
   (minor  nix-server-minor-version)
 
+  ;; Hash table that maps store items to a "build continuation" for that store
+  ;; item.
+  (continuations nix-server-build-continuations)
+
   ;; Caches.  We keep them per-connection, because store paths build
   ;; during the session are temporary GC roots kept for the duration of
   ;; the session.
@@ -400,6 +406,7 @@ for this connection will be pinned.  Return a server object."
                                                     (protocol-major v)
                                                     (protocol-minor v)
                                                     (make-hash-table 100)
+                                                    (make-hash-table 100)
                                                     (make-hash-table 100))))
                         (let loop ((done? (process-stderr conn)))
                           (or done? (process-stderr conn)))
@@ -720,7 +727,19 @@ where FILE is the entry's absolute file name and STAT is the result of
               (hash-set! cache args path)
               path))))))
 
-(define build-things
+(define (set-build-continuation! store item proc)
+  "Register PROC as a \"build continuation\" for when ITEM is built on STORE.
+When 'build-things' is passed ITEM, it calls (PROC STORE ITEM), which must
+return a list of store items to build."
+  (hash-set! (nix-server-build-continuations store) item proc))
+
+(define (build-continuation store item)
+  "Return the procedure that implements a \"build continuation\" for ITEM, or
+#f if there is none."
+  (hash-ref (nix-server-build-continuations store) item))
+
+(define %build-things
+  ;; This is the raw RPC.
   (let ((build (operation (build-things (string-list things)
                                         (integer mode))
                           "Do it!"
@@ -741,6 +760,29 @@ Return #t on success."
                                  (message "unsupported build mode")
                                  (status  1)))))))))
 
+(define* (build-things store things
+                       #:optional (mode (build-mode normal))
+                       #:key (continuations? #t))
+  "Build THINGS, a list of store items which may be either '.drv' files or
+outputs, and return when the worker is done building them.  Elements of THINGS
+that are not derivations can only be substituted and not built locally.  When
+CONTINUATIONS? is true, run the \"build continuations\" of THINGS.  Return the
+list of store items built."
+  (let loop ((things things)
+             (built '()))
+    (match things
+      (()
+       built)
+      (_
+       (and (%build-things store things mode)
+            (loop (append-map (lambda (thing)
+                                (let ((proc (build-continuation store thing)))
+                                  (if proc
+                                      (proc store thing)
+                                      '())))
+                              things)
+                  things))))))
+
 (define-operation (add-temp-root (store-path path))
   "Make PATH a temporary root for the duration of the current session.
 Return #t."
@@ -1184,6 +1226,12 @@ where FILE is the entry's absolute file name and STAT is the result of
   ;; Monadic variant of 'build-things'.
   (store-lift build-things))
 
+(define (set-build-continuation item proc)
+  "Register monadic thunk PROC as a \"build continuation\" for ITEM."
+  (lambda (store)
+    (set-build-continuation! store item (store-lower proc))
+    (values *unspecified* store)))
+
 (define set-build-options*
   (store-lift set-build-options))
 

guix/ui.scm

@@ -67,7 +67,6 @@
             make-regexp*
             string->number*
             size->number
-            show-derivation-outputs
             show-what-to-build
             show-what-to-build*
             show-manifest-transaction
@@ -548,14 +547,6 @@ error."
      (leave (_ "expression ~s does not evaluate to a package~%")
             str))))
 
-(define (show-derivation-outputs derivation)
-  "Show the output file names of DERIVATION."
-  (format #t "~{~a~%~}"
-          (map (match-lambda
-                 ((out-name . out)
-                  (derivation->output-path derivation out-name)))
-               (derivation-outputs derivation))))
-
 (define* (show-what-to-build store drv
                              #:key dry-run? (use-substitutes? #t)
                              (mode (build-mode normal)))

guix/upstream.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -201,9 +201,7 @@ values: 'interactive' (default), 'always', and 'never'."
                          (run-with-store store
                            (mlet %store-monad ((drv (uncompressed-tarball
                                                      (basename url) tarball)))
-                             (mbegin %store-monad
-                               (built-derivations (list drv))
-                               (return (derivation->output-path drv)))))))
+                             (built-derivations (list drv))))))
 
                (ret  (gnupg-verify* sig data #:key-download key-download)))
           (if ret

tests/gexp.scm

@@ -434,24 +434,38 @@
                  (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"
+                               (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))))
+         (exp2  (gexp (frob (ungexp (list (gexp-input p1))))))
+         (exp3  (gexp (stuff (ungexp exp1))))
+         (exp4  (gexp (frob (ungexp (file-append p1 "/bin/foo")))))
+         (exp5  (gexp (frob (ungexp (computed-file "foo" exp1)))))
+         (exp6  (gexp (frob (ungexp (program-file "foo" exp1)))))
+         (exp7  (gexp (frob (ungexp (scheme-file "foo" exp1))))))
+    (mlet* %store-monad ((grafts0 (gexp-grafts exp0))
+                         (grafts1 (gexp-grafts exp1))
+                         (grafts2 (gexp-grafts exp2))
+                         (grafts3 (gexp-grafts exp3))
+                         (grafts4 (gexp-grafts exp4))
+                         (grafts5 (gexp-grafts exp5))
+                         (grafts6 (gexp-grafts exp6))
+                         (grafts7 (gexp-grafts exp7))
+                         (p0-drv  (package->derivation p0))
+                         (r-drv   (package->derivation r))
+                         (expected -> (graft
+                                        (origin p0-drv)
+                                        (replacement r-drv))))
+      (return (and (null? grafts0)
+                   (equal? grafts1 grafts2 grafts3 grafts4
+                           grafts5 grafts6 grafts7
+                           (list expected)))))))
 
 (test-assertm "gexp->derivation, composed gexps"
   (mlet* %store-monad ((exp0 -> (gexp (begin