From ce45eb4c385e3b473bc6746a8b58452865f69977 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Fri, 13 Feb 2015 23:14:05 +0100
Subject: 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.
---
 guix/gexp.scm | 62 ++++++++++++++++++++++++++++++++---------------------------
 1 file changed, 34 insertions(+), 28 deletions(-)

(limited to 'guix/gexp.scm')

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 @@ (define* (gexp->derivation name exp
                            (modules '())
                            (module-path %load-path)
                            (guile-for-build (%guile-for-build))
+                           (graft? (%graft?))
                            references-graphs
                            allowed-references
                            local-build?)
@@ -165,6 +166,9 @@ (define* (gexp->derivation name exp
 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 @@ (define (graphs-file-names graphs)
             (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 @@ (define (graphs-file-names graphs)
                                      (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
-- 
cgit v1.2.3