02/16: gexp: Add 'with-imported-modules' macro.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 0bb9929eaa3f963ae75478e789723f9e8582116b
Author: Ludovic Courtès <address@hidden>
Date:   Sun Jul 3 22:26:19 2016 +0200

    gexp: Add 'with-imported-modules' macro.
    
    * guix/gexp.scm (<gexp>)[modules]: New field.
    (gexp-modules): New procedure.
    (gexp->derivation): Use it and append the result to %MODULES.
    Update docstring to mark #:modules as deprecated.
    (current-imported-modules, with-imported-modules): New macros.
    (gexp): Pass CURRENT-IMPORTED-MODULES as second argument to 'gexp'.
    (gexp->script): Use and honor 'gexp-modules'; define '%modules'.
    * tests/gexp.scm ("gexp->derivation & with-imported-modules")
    ("gexp->derivation & nested with-imported-modules")
    ("gexp-modules & ungexp", "gexp-modules & ungexp-splicing"):
    New tests.
    ("program-file"): Use 'with-imported-modules'.  Remove #:modules
    argument to 'program-file'.
    * doc/guix.texi (G-Expressions): Document 'with-imported-modules'.
    Mark #:modules of 'gexp->derivation' as deprecated.
    * emacs/guix-devel.el: Add syntax for 'with-imported-modules'.
    (guix-devel-keywords): Add it.
    * .dir-locals.el: Likewise.
---
 .dir-locals.el      |    1 +
 doc/guix.texi       |   38 +++++++++++++++++++++++++++++-
 emacs/guix-devel.el |    2 ++
 guix/gexp.scm       |   47 +++++++++++++++++++++++++++++++++----
 tests/gexp.scm      |   64 +++++++++++++++++++++++++++++++++++++++++++++++----
 5 files changed, 142 insertions(+), 10 deletions(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index 0873c1d..c7ceb9e 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -59,6 +59,7 @@
    (eval . (put 'run-with-store 'scheme-indent-function 1))
    (eval . (put 'run-with-state 'scheme-indent-function 1))
    (eval . (put 'wrap-program 'scheme-indent-function 1))
+   (eval . (put 'with-imported-modules 'scheme-indent-function 1))
 
    (eval . (put 'call-with-container 'scheme-indent-function 1))
    (eval . (put 'container-excursion 'scheme-indent-function 1))
diff --git a/doc/guix.texi b/doc/guix.texi
index c9d9bd8..b315325 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -3697,6 +3697,30 @@ In the example above, the native build of 
@var{coreutils} is used, so
 that @command{ln} can actually run on the host; but then the
 cross-compiled build of @var{emacs} is referenced.
 
address@hidden imported modules, for gexps
address@hidden with-imported-modules
+Another gexp feature is @dfn{imported modules}: sometimes you want to be
+able to use certain Guile modules from the ``host environment'' in the
+gexp, so those modules should be imported in the ``build environment''.
+The @code{with-imported-modules} form allows you to express that:
+
address@hidden
+(let ((build (with-imported-modules '((guix build utils))
+               #~(begin
+                   (use-modules (guix build utils))
+                   (mkdir-p (string-append #$output "/bin"))))))
+  (gexp->derivation "empty-dir"
+                    #~(begin
+                        #$build
+                        (display "success!\n")
+                        #t)))
address@hidden example
+
address@hidden
+In this example, the @code{(guix build utils)} module is automatically
+pulled into the isolated build environment of our gexp, such that
address@hidden(use-modules (guix build utils))} works as expected.
+
 The syntactic form to construct gexps is summarized below.
 
 @deffn {Scheme Syntax} address@hidden
@@ -3756,6 +3780,16 @@ G-expressions created by @code{gexp} or @code{#~} are 
run-time objects
 of the @code{gexp?} type (see below.)
 @end deffn
 
address@hidden {Scheme Syntax} with-imported-modules @var{modules} 
@address@hidden
+Mark the gexps defined in @address@hidden as requiring @var{modules}
+in their execution environment.  @var{modules} must be a list of Guile
+module names, such as @code{'((guix build utils) (guix build gremlin))}.
+
+This form has @emph{lexical} scope: it has an effect on the gexps
+directly defined in @address@hidden, but not on those defined, say, in
+procedures called from @address@hidden
address@hidden deffn
+
 @deffn {Scheme Procedure} gexp? @var{obj}
 Return @code{#t} if @var{obj} is a G-expression.
 @end deffn
@@ -3781,7 +3815,9 @@ stored in a file called @var{script-name}.  When 
@var{target} 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};
address@hidden is deprecated in favor of @code{with-imported-modules}.
+Its meaning is to
+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
diff --git a/emacs/guix-devel.el b/emacs/guix-devel.el
index ee8371c..b71670c 100644
--- a/emacs/guix-devel.el
+++ b/emacs/guix-devel.el
@@ -216,6 +216,7 @@ to find 'modify-phases' keywords."
     "with-derivation-substitute"
     "with-directory-excursion"
     "with-error-handling"
+    "with-imported-modules"
     "with-monad"
     "with-mutex"
     "with-store"))
@@ -306,6 +307,7 @@ Each rule should have a form (SYMBOL VALUE).  See `put' for 
details."
   (with-derivation-substitute 2)
   (with-directory-excursion 1)
   (with-error-handling 0)
+  (with-imported-modules 1)
   (with-monad 1)
   (with-mutex 1)
   (with-store 1)
diff --git a/guix/gexp.scm b/guix/gexp.scm
index c86f4d0..e9274a0 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -29,6 +29,7 @@
   #:use-module (ice-9 match)
   #:export (gexp
             gexp?
+            with-imported-modules
 
             gexp-input
             gexp-input?
@@ -98,9 +99,10 @@
 
 ;; "G expressions".
 (define-record-type <gexp>
-  (make-gexp references proc)
+  (make-gexp references modules proc)
   gexp?
   (references gexp-references)                    ;list of <gexp-input>
+  (modules    gexp-self-modules)                  ;list of module names
   (proc       gexp-proc))                         ;procedure
 
 (define (write-gexp gexp port)
@@ -384,6 +386,23 @@ whether this should be considered a \"native\" input or 
not."
 
 (set-record-type-printer! <gexp-output> write-gexp-output)
 
+(define (gexp-modules gexp)
+  "Return the list of Guile module names GEXP relies on."
+  (delete-duplicates
+   (append (gexp-self-modules gexp)
+           (append-map (match-lambda
+                         (($ <gexp-input> (? gexp? exp))
+                          (gexp-modules exp))
+                         (($ <gexp-input> (lst ...))
+                          (append-map (lambda (item)
+                                        (if (gexp? item)
+                                            (gexp-modules item)
+                                            '()))
+                                      lst))
+                         (_
+                          '()))
+                       (gexp-references gexp)))))
+
 (define raw-derivation
   (store-lift derivation))
 
@@ -465,7 +484,8 @@ derivation) on SYSTEM; EXP is stored in a file called 
SCRIPT-NAME.  When
 TARGET is true, it is used as the cross-compilation target triplet for
 packages referred to by EXP.
 
-Make MODULES available in the evaluation context of EXP; MODULES is a list of
+MODULES is deprecated in favor of 'with-imported-modules'.  Its meaning is to
+make MODULES available in the evaluation context of EXP; MODULES is a list of
 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)).
@@ -494,7 +514,9 @@ Similarly for DISALLOWED-REFERENCES, which can list items 
that must not be
 referenced by the outputs.
 
 The other arguments are as for 'derivation'."
-  (define %modules modules)
+  (define %modules
+    (delete-duplicates
+     (append modules (gexp-modules exp))))
   (define outputs (gexp-outputs exp))
 
   (define (graphs-file-names graphs)
@@ -724,6 +746,17 @@ and in the current monad setting (system type, etc.)"
               (simple-format #f "~a:~a" line column)))
         "<unknown location>")))
 
+(define-syntax-parameter current-imported-modules
+  ;; Current list of imported modules.
+  (identifier-syntax '()))
+
+(define-syntax-rule (with-imported-modules modules body ...)
+  "Mark the gexps defined in BODY... as requiring MODULES in their execution
+environment."
+  (syntax-parameterize ((current-imported-modules
+                         (identifier-syntax modules)))
+    body ...))
+
 (define-syntax gexp
   (lambda (s)
     (define (collect-escapes exp)
@@ -819,6 +852,7 @@ and in the current monad setting (system type, etc.)"
               (sexp    (substitute-references #'exp (zip escapes formals)))
               (refs    (map escape->ref escapes)))
          #`(make-gexp (list #,@refs)
+                      current-imported-modules
                       (lambda #,formals
                         #,sexp)))))))
 
@@ -960,8 +994,11 @@ they can refer to each other."
                        #:key (modules '()) (guile (default-guile)))
   "Return an executable script NAME that runs EXP using GUILE with MODULES in
 its search path."
-  (mlet %store-monad ((modules  (imported-modules modules))
-                      (compiled (compiled-modules modules)))
+  (define %modules
+    (append (gexp-modules exp) modules))
+
+  (mlet %store-monad ((modules  (imported-modules %modules))
+                      (compiled (compiled-modules %modules)))
     (gexp->derivation name
                       (gexp
                        (call-with-output-file (ungexp output)
diff --git a/tests/gexp.scm b/tests/gexp.scm
index f44f0ea..36ce66f 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -526,6 +526,18 @@
                             get-bytevector-all))))
                 files))))))
 
+(test-equal "gexp-modules & ungexp"
+  '((bar) (foo))
+  ((@@ (guix gexp) gexp-modules)
+   #~(foo #$(with-imported-modules '((foo)) #~+)
+          #+(with-imported-modules '((bar)) #~-))))
+
+(test-equal "gexp-modules & ungexp-splicing"
+  '((foo) (bar))
+  ((@@ (guix gexp) gexp-modules)
+   #~(foo #$@(list (with-imported-modules '((foo)) #~+)
+                   (with-imported-modules '((bar)) #~-)))))
+
 (test-assertm "gexp->derivation #:modules"
   (mlet* %store-monad
       ((build ->  #~(begin
@@ -540,6 +552,50 @@
              (s (stat (string-append p "/guile/guix/nix"))))
         (return (eq? (stat:type s) 'directory))))))
 
+(test-assertm "gexp->derivation & with-imported-modules"
+  ;; Same test as above, but using 'with-imported-modules'.
+  (mlet* %store-monad
+      ((build ->  (with-imported-modules '((guix build utils))
+                    #~(begin
+                        (use-modules (guix build utils))
+                        (mkdir-p (string-append #$output "/guile/guix/nix"))
+                        #t)))
+       (drv       (gexp->derivation "test-with-modules" build)))
+    (mbegin %store-monad
+      (built-derivations (list drv))
+      (let* ((p (derivation->output-path drv))
+             (s (stat (string-append p "/guile/guix/nix"))))
+        (return (eq? (stat:type s) 'directory))))))
+
+(test-assertm "gexp->derivation & nested with-imported-modules"
+  (mlet* %store-monad
+      ((build1 ->  (with-imported-modules '((guix build utils))
+                     #~(begin
+                         (use-modules (guix build utils))
+                         (mkdir-p (string-append #$output "/guile/guix/nix"))
+                         #t)))
+       (build2 ->  (with-imported-modules '((guix build bournish))
+                     #~(begin
+                         (use-modules (guix build bournish)
+                                      (system base compile))
+                         #+build1
+                         (call-with-output-file (string-append #$output "/b")
+                           (lambda (port)
+                             (write
+                              (read-and-compile (open-input-string "cd /foo")
+                                                #:from %bournish-language
+                                                #:to 'scheme)
+                              port))))))
+       (drv        (gexp->derivation "test-with-modules" build2)))
+    (mbegin %store-monad
+      (built-derivations (list drv))
+      (let* ((p (derivation->output-path drv))
+             (s (stat (string-append p "/guile/guix/nix")))
+             (b (string-append p "/b")))
+        (return (and (eq? (stat:type s) 'directory)
+                     (equal? '(chdir "/foo")
+                             (call-with-input-file b read))))))))
+
 (test-assertm "gexp->derivation #:references-graphs"
   (mlet* %store-monad
       ((one (text-file "one" (random-text)))
@@ -676,11 +732,11 @@
 
 (test-assertm "program-file"
   (let* ((n      (random (expt 2 50)))
-         (exp    (gexp (begin
-                         (use-modules (guix build utils))
-                         (display (ungexp n)))))
+         (exp    (with-imported-modules '((guix build utils))
+                   (gexp (begin
+                           (use-modules (guix build utils))
+                           (display (ungexp n))))))
          (file   (program-file "program" exp
-                               #:modules '((guix build utils))
                                #:guile %bootstrap-guile)))
     (mlet* %store-monad ((drv (lower-object file))
                          (out -> (derivation->output-path drv)))