gexp: Add #:graft? parameter to 'gexp->derivation'.

* guix/gexp.scm (gexp->derivation): Add #:graft? parameter and honor it.
* tests/gexp.scm ("gexp->derivation vs. grafts"): New test.
* doc/guix.texi (G-Expressions): Update 'gexp->derivation'
  documentation.

3 files changed, 58 insertions, 32 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index 04b9b4aaae..50a7084fec 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -2580,7 +2580,7 @@ below allow you to do that (@pxref{The Store Monad}, for more
 information about monads.)
 
 @deffn {Monadic Procedure} gexp->derivation @var{name} @var{exp} @
-       [#:system (%current-system)] [#:target #f] [#:inputs '()] @
+       [#:system (%current-system)] [#:target #f] [#:graft? #t] @
        [#:hash #f] [#:hash-algo #f] @
        [#:recursive? #f] [#:env-vars '()] [#:modules '()] @
        [#:module-path @var{%load-path}] @
@@ -2591,12 +2591,15 @@ Return a derivation @var{name} that runs @var{exp} (a gexp) with
 is true, it is used as the cross-compilation target triplet for packages
 referred to by @var{exp}.
 
-Make @var{modules} available in the evaluation context of @var{EXP};
-@var{MODULES} is a list of names of Guile modules searched in
-@var{MODULE-PATH} to be copied in the store, compiled, and made available in
+Make @var{modules} available in the evaluation context of @var{exp};
+@var{modules} is a list of names of Guile modules searched in
+@var{module-path} to be copied in the store, compiled, and made available in
 the load path during the execution of @var{exp}---e.g., @code{((guix
 build utils) (guix build gnu-build-system))}.
 
+@var{graft?} determines whether packages referred to by @var{exp} should be grafted when
+applicable.
+
 When @var{references-graphs} is true, it must be a list of tuples of one of the
 following forms:
 
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 0620683078..a8349c7d6e 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -153,6 +153,7 @@ names and file names suitable for the #:allowed-references argument to
                            (modules '())
                            (module-path %load-path)
                            (guile-for-build (%guile-for-build))
+                           (graft? (%graft?))
                            references-graphs
                            allowed-references
                            local-build?)
@@ -165,6 +166,9 @@ names of Guile modules searched in MODULE-PATH to be copied in the store,
 compiled, and made available in the load path during the execution of
 EXP---e.g., '((guix build utils) (guix build gnu-build-system)).
 
+GRAFT? determines whether packages referred to by EXP should be grafted when
+applicable.
+
 When REFERENCES-GRAPHS is true, it must be a list of tuples of one of the
 following forms:
 
@@ -198,10 +202,10 @@ The other arguments are as for 'derivation'."
             (cons file-name thing)))
          graphs))
 
-  (mlet* %store-monad (;; The following binding is here to force
-                       ;; '%current-system' and '%current-target-system' to be
-                       ;; looked up at >>= time.
-                       (unused    (return #f))
+  (mlet* %store-monad (;; The following binding forces '%current-system' and
+                       ;; '%current-target-system' to be looked up at >>=
+                       ;; time.
+                       (graft?    (set-grafting graft?))
 
                        (system -> (or system (%current-system)))
                        (target -> (if (eq? target 'current)
@@ -245,30 +249,32 @@ The other arguments are as for 'derivation'."
                                      (return guile-for-build)
                                      (package->derivation (default-guile)
                                                           system))))
-    (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
-                    #:local-build? local-build?)))
+    (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
+                      #:local-build? local-build?))))
 
 (define* (gexp-inputs exp #:optional (references gexp-references))
   "Return the input list for EXP, using REFERENCES to get its list of
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 68c470d3b6..0b189b570b 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -249,6 +249,23 @@
                  (equal? refs (list (dirname (dirname guile))))
                  (equal? refs2 (list file))))))
 
+(test-assertm "gexp->derivation vs. grafts"
+  (mlet* %store-monad ((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))
+                       (drv1    (gexp->derivation "t" exp1))
+                       (drv1*   (gexp->derivation "t" exp1 #:graft? #f)))
+    (return (and (not (string=? (derivation->output-path drv0)
+                                (derivation->output-path drv1)))
+                 (string=? (derivation->output-path drv0)
+                           (derivation->output-path drv1*))))))
+
 (test-assertm "gexp->derivation, composed gexps"
   (mlet* %store-monad ((exp0 -> (gexp (begin
                                         (mkdir (ungexp output))