gexp: Add 'with-extensions'.

* guix/gexp.scm (<gexp>)[extensions]: New field.
(gexp-attribute): New procedure.
(gexp-modules): Write in terms of 'gexp-attribute'.
(gexp-extensions): New procedure.
(gexp->derivation): Add #:effective-version.
[extension-flags]: New procedure.
Honor extensions of EXP.
(current-imported-extensions): New syntax parameter.
(with-extensions): New macro.
(gexp): Honor CURRENT-IMPORTED-EXTENSIONS.
(compiled-modules): Add #:extensions and honor it.
(load-path-expression): Likewise.
(gexp->script, gexp->file): Honor extensions.
* tests/gexp.scm (%extension-package): New variable.
("gexp-extensions & ungexp")
("gexp-extensions & ungexp-splicing")
("gexp-extensions and literal Scheme object")
("gexp->derivation & with-extensions")
("program-file & with-extensions"): New tests.
* doc/guix.texi (G-Expressions): Document 'with-extensions'.

4 files changed, 246 insertions, 42 deletions

diff --git a/.dir-locals.el b/.dir-locals.el
index dac6cb1453..2db751ca22 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -73,6 +73,7 @@
    (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 'with-extensions '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 3b5078741d..77bdaa50eb 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -5064,6 +5064,23 @@ headers, which comes in handy in this case:
                         @dots{})))
 @end example
 
+@cindex extensions, for gexps
+@findex with-extensions
+In the same vein, sometimes you want to import not just pure-Scheme
+modules, but also ``extensions'' such as Guile bindings to C libraries
+or other ``full-blown'' packages.  Say you need the @code{guile-json}
+package available on the build side, here's how you would do it:
+
+@example
+(use-modules (gnu packages guile))  ;for 'guile-json'
+
+(with-extensions (list guile-json)
+  (gexp->derivation "something-with-json"
+                    #~(begin
+                        (use-modules (json))
+                        @dots{})))
+@end example
+
 The syntactic form to construct gexps is summarized below.
 
 @deffn {Scheme Syntax} #~@var{exp}
@@ -5147,6 +5164,18 @@ directly defined in @var{body}@dots{}, but not on those defined, say, in
 procedures called from @var{body}@dots{}.
 @end deffn
 
+@deffn {Scheme Syntax} with-extensions @var{extensions} @var{body}@dots{}
+Mark the gexps defined in @var{body}@dots{} as requiring
+@var{extensions} in their build and execution environment.
+@var{extensions} is typically a list of package objects such as those
+defined in the @code{(gnu packages guile)} module.
+
+Concretely, the packages listed in @var{extensions} are added to the
+load path while compiling imported modules in @var{body}@dots{}; they
+are also added to the load path of the gexp returned by
+@var{body}@dots{}.
+@end deffn
+
 @deffn {Scheme Procedure} gexp? @var{obj}
 Return @code{#t} if @var{obj} is a G-expression.
 @end deffn
@@ -5161,6 +5190,7 @@ information about monads.)
        [#:hash #f] [#:hash-algo #f] @
        [#:recursive? #f] [#:env-vars '()] [#:modules '()] @
        [#:module-path @var{%load-path}] @
+       [#:effective-version "2.2"] @
        [#:references-graphs #f] [#:allowed-references #f] @
        [#:disallowed-references #f] @
        [#:leaked-env-vars #f] @
@@ -5181,6 +5211,9 @@ make @var{modules} available in the evaluation context of @var{exp};
 the load path during the execution of @var{exp}---e.g., @code{((guix
 build utils) (guix build gnu-build-system))}.
 
+@var{effective-version} determines the string to use when adding extensions of
+@var{exp} (see @code{with-extensions}) to the search path---e.g., @code{"2.2"}.
+
 @var{graft?} determines whether packages referred to by @var{exp} should be grafted when
 applicable.
 
diff --git a/guix/gexp.scm b/guix/gexp.scm
index fdfd734245..338c339da9 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -33,6 +33,7 @@
   #:export (gexp
             gexp?
             with-imported-modules
+            with-extensions
 
             gexp-input
             gexp-input?
@@ -118,10 +119,11 @@
 
 ;; "G expressions".
 (define-record-type <gexp>
-  (make-gexp references modules proc)
+  (make-gexp references modules extensions proc)
   gexp?
   (references gexp-references)                    ;list of <gexp-input>
   (modules    gexp-self-modules)                  ;list of module names
+  (extensions gexp-self-extensions)               ;list of lowerable things
   (proc       gexp-proc))                         ;procedure
 
 (define (write-gexp gexp port)
@@ -492,19 +494,20 @@ 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.  If (gexp? GEXP) is
-false, meaning that GEXP is a plain Scheme object, return the empty list."
+(define (gexp-attribute gexp self-attribute)
+  "Recurse on GEXP and the expressions it refers to, summing the items
+returned by SELF-ATTRIBUTE, a procedure that takes a gexp."
   (if (gexp? gexp)
       (delete-duplicates
-       (append (gexp-self-modules gexp)
+       (append (self-attribute gexp)
                (append-map (match-lambda
                              (($ <gexp-input> (? gexp? exp))
-                              (gexp-modules exp))
+                              (gexp-attribute exp self-attribute))
                              (($ <gexp-input> (lst ...))
                               (append-map (lambda (item)
                                             (if (gexp? item)
-                                                (gexp-modules item)
+                                                (gexp-attribute item
+                                                                self-attribute)
                                                 '()))
                                           lst))
                              (_
@@ -512,6 +515,17 @@ false, meaning that GEXP is a plain Scheme object, return the empty list."
                            (gexp-references gexp))))
       '()))                                       ;plain Scheme data type
 
+(define (gexp-modules gexp)
+  "Return the list of Guile module names GEXP relies on.  If (gexp? GEXP) is
+false, meaning that GEXP is a plain Scheme object, return the empty list."
+  (gexp-attribute gexp gexp-self-modules))
+
+(define (gexp-extensions gexp)
+  "Return the list of Guile extensions (packages) GEXP relies on.  If (gexp?
+GEXP) is false, meaning that GEXP is a plain Scheme object, return the empty
+list."
+  (gexp-attribute gexp gexp-self-extensions))
+
 (define* (lower-inputs inputs
                        #:key system target)
   "Turn any package from INPUTS into a derivation for SYSTEM; return the
@@ -577,6 +591,7 @@ names and file names suitable for the #:allowed-references argument to
                            (modules '())
                            (module-path %load-path)
                            (guile-for-build (%guile-for-build))
+                           (effective-version "2.2")
                            (graft? (%graft?))
                            references-graphs
                            allowed-references disallowed-references
@@ -595,6 +610,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)).
 
+EFFECTIVE-VERSION determines the string to use when adding extensions of
+EXP (see 'with-extensions') to the search path---e.g., \"2.2\".
+
 GRAFT? determines whether packages referred to by EXP should be grafted when
 applicable.
 
@@ -630,7 +648,7 @@ The other arguments are as for 'derivation'."
   (define (graphs-file-names graphs)
     ;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS.
     (map (match-lambda
-          ;; TODO: Remove 'derivation?' special cases.
+           ;; TODO: Remove 'derivation?' special cases.
            ((file-name (? derivation? drv))
             (cons file-name (derivation->output-path drv)))
            ((file-name (? derivation? drv) sub-drv)
@@ -639,7 +657,13 @@ The other arguments are as for 'derivation'."
             (cons file-name thing)))
          graphs))
 
-  (mlet* %store-monad (;; The following binding forces '%current-system' and
+  (define (extension-flags extension)
+    `("-L" ,(string-append (derivation->output-path extension)
+                           "/share/guile/site/" effective-version)
+      "-C" ,(string-append (derivation->output-path extension)
+                           "/lib/guile/" effective-version "/site-ccache")))
+
+  (mlet* %store-monad ( ;; The following binding forces '%current-system' and
                        ;; '%current-target-system' to be looked up at >>=
                        ;; time.
                        (graft?    (set-grafting graft?))
@@ -660,6 +684,11 @@ The other arguments are as for 'derivation'."
                                              #:target target))
                        (builder  (text-file script-name
                                             (object->string sexp)))
+                       (extensions -> (gexp-extensions exp))
+                       (exts     (mapm %store-monad
+                                       (lambda (obj)
+                                         (lower-object obj system))
+                                       extensions))
                        (modules  (if (pair? %modules)
                                      (imported-modules %modules
                                                        #:system system
@@ -672,6 +701,7 @@ The other arguments are as for 'derivation'."
                                      (compiled-modules %modules
                                                        #:system system
                                                        #:module-path module-path
+                                                       #:extensions extensions
                                                        #:guile guile-for-build
                                                        #:deprecation-warnings
                                                        deprecation-warnings)
@@ -704,6 +734,7 @@ The other arguments are as for 'derivation'."
                               `("-L" ,(derivation->output-path modules)
                                 "-C" ,(derivation->output-path compiled))
                               '())
+                        ,@(append-map extension-flags exts)
                         ,builder)
                       #:outputs outputs
                       #:env-vars env-vars
@@ -713,6 +744,7 @@ The other arguments are as for 'derivation'."
                                  ,@(if modules
                                        `((,modules) (,compiled) ,@inputs)
                                        inputs)
+                                 ,@(map list exts)
                                  ,@(match graphs
                                      (((_ . inputs) ...) inputs)
                                      (_ '())))
@@ -861,6 +893,17 @@ environment."
                          (identifier-syntax modules)))
     body ...))
 
+(define-syntax-parameter current-imported-extensions
+  ;; Current list of extensions.
+  (identifier-syntax '()))
+
+(define-syntax-rule (with-extensions extensions body ...)
+  "Mark the gexps defined in BODY... as requiring EXTENSIONS in their
+execution environment."
+  (syntax-parameterize ((current-imported-extensions
+                         (identifier-syntax extensions)))
+    body ...))
+
 (define-syntax gexp
   (lambda (s)
     (define (collect-escapes exp)
@@ -957,6 +1000,7 @@ environment."
               (refs    (map escape->ref escapes)))
          #`(make-gexp (list #,@refs)
                       current-imported-modules
+                      current-imported-extensions
                       (lambda #,formals
                         #,sexp)))))))
 
@@ -1071,6 +1115,7 @@ last one is created from the given <scheme-file> object."
                            (system (%current-system))
                            (guile (%guile-for-build))
                            (module-path %load-path)
+                           (extensions '())
                            (deprecation-warnings #f))
   "Return a derivation that builds a tree containing the `.go' files
 corresponding to MODULES.  All the MODULES are built in a context where
@@ -1129,6 +1174,26 @@ they can refer to each other."
                        (@ (guix build utils) mkdir-p))))
               '()))
 
+         ;; Add EXTENSIONS to the search path.
+         ;; TODO: Remove the outer 'ungexp-splicing' on the next rebuild cycle.
+         (ungexp-splicing
+          (if (null? extensions)
+              '()
+              (gexp ((set! %load-path
+                       (append (map (lambda (extension)
+                                      (string-append extension
+                                                     "/share/guile/site/"
+                                                     (effective-version)))
+                                    '((ungexp-native-splicing extensions)))
+                               %load-path))
+                     (set! %load-compiled-path
+                       (append (map (lambda (extension)
+                                      (string-append extension "/lib/guile/"
+                                                     (effective-version)
+                                                     "/site-ccache"))
+                                    '((ungexp-native-splicing extensions)))
+                               %load-compiled-path))))))
+
          (set! %load-path (cons (ungexp modules) %load-path))
 
          (ungexp-splicing
@@ -1174,20 +1239,34 @@ they can refer to each other."
   (module-ref (resolve-interface '(gnu packages guile))
               'guile-2.2))
 
-(define* (load-path-expression modules #:optional (path %load-path))
+(define* (load-path-expression modules #:optional (path %load-path)
+                               #:key (extensions '()))
   "Return as a monadic value a gexp that sets '%load-path' and
 '%load-compiled-path' to point to MODULES, a list of module names.  MODULES
 are searched for in PATH."
   (mlet %store-monad ((modules  (imported-modules modules
                                                   #:module-path path))
                       (compiled (compiled-modules modules
+                                                  #:extensions extensions
                                                   #:module-path path)))
     (return (gexp (eval-when (expand load eval)
                     (set! %load-path
-                      (cons (ungexp modules) %load-path))
+                      (cons (ungexp modules)
+                            (append (map (lambda (extension)
+                                           (string-append extension
+                                                          "/share/guile/site/"
+                                                          (effective-version)))
+                                         '((ungexp-native-splicing extensions)))
+                                    %load-path)))
                     (set! %load-compiled-path
                       (cons (ungexp compiled)
-                            %load-compiled-path)))))))
+                            (append (map (lambda (extension)
+                                           (string-append extension
+                                                          "/lib/guile/"
+                                                          (effective-version)
+                                                          "/site-ccache"))
+                                         '((ungexp-native-splicing extensions)))
+                                    %load-compiled-path))))))))
 
 (define* (gexp->script name exp
                        #:key (guile (default-guile))
@@ -1196,7 +1275,9 @@ are searched for in PATH."
 imported modules in its search path.  Look up EXP's modules in MODULE-PATH."
   (mlet %store-monad ((set-load-path
                        (load-path-expression (gexp-modules exp)
-                                             module-path)))
+                                             module-path
+                                             #:extensions
+                                             (gexp-extensions exp))))
     (gexp->derivation name
                       (gexp
                        (call-with-output-file (ungexp output)
@@ -1225,35 +1306,38 @@ the resulting file.
 When SET-LOAD-PATH? is true, emit code in the resulting file to set
 '%load-path' and '%load-compiled-path' to honor EXP's imported modules.
 Lookup EXP's modules in MODULE-PATH."
-  (match (if set-load-path? (gexp-modules exp) '())
-    (()                                           ;zero modules
-     (gexp->derivation name
-                       (gexp
-                        (call-with-output-file (ungexp output)
-                          (lambda (port)
-                            (for-each (lambda (exp)
-                                        (write exp port))
-                                      '(ungexp (if splice?
-                                                   exp
-                                                   (gexp ((ungexp exp)))))))))
-                       #:local-build? #t
-                       #:substitutable? #f))
-    ((modules ...)
-     (mlet %store-monad ((set-load-path (load-path-expression modules
-                                                              module-path)))
-       (gexp->derivation name
-                         (gexp
-                          (call-with-output-file (ungexp output)
-                            (lambda (port)
-                              (write '(ungexp set-load-path) port)
-                              (for-each (lambda (exp)
-                                          (write exp port))
-                                        '(ungexp (if splice?
-                                                     exp
-                                                     (gexp ((ungexp exp)))))))))
-                         #:module-path module-path
-                         #:local-build? #t
-                         #:substitutable? #f)))))
+  (define modules (gexp-modules exp))
+  (define extensions (gexp-extensions exp))
+
+  (if (or (not set-load-path?)
+          (and (null? modules) (null? extensions)))
+      (gexp->derivation name
+                        (gexp
+                         (call-with-output-file (ungexp output)
+                           (lambda (port)
+                             (for-each (lambda (exp)
+                                         (write exp port))
+                                       '(ungexp (if splice?
+                                                    exp
+                                                    (gexp ((ungexp exp)))))))))
+                        #:local-build? #t
+                        #:substitutable? #f)
+      (mlet %store-monad ((set-load-path
+                           (load-path-expression modules module-path
+                                                 #:extensions extensions)))
+        (gexp->derivation name
+                          (gexp
+                           (call-with-output-file (ungexp output)
+                             (lambda (port)
+                               (write '(ungexp set-load-path) port)
+                               (for-each (lambda (exp)
+                                           (write exp port))
+                                         '(ungexp (if splice?
+                                                      exp
+                                                      (gexp ((ungexp exp)))))))))
+                          #:module-path module-path
+                          #:local-build? #t
+                          #:substitutable? #f))))
 
 (define* (text-file* name #:rest text)
   "Return as a monadic value a derivation that builds a text file containing
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 3c8b4624da..a560adfc5c 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -23,6 +23,7 @@
   #:use-module (guix grafts)
   #:use-module (guix derivations)
   #:use-module (guix packages)
+  #:use-module (guix build-system trivial)
   #:use-module (guix tests)
   #:use-module ((guix build utils) #:select (with-directory-excursion))
   #:use-module ((guix utils) #:select (call-with-temporary-directory))
@@ -66,6 +67,27 @@
     (run-with-store %store exp
                     #:guile-for-build (%guile-for-build))))
 
+(define %extension-package
+  ;; Example of a package to use when testing 'with-extensions'.
+  (dummy-package "extension"
+                 (build-system trivial-build-system)
+                 (arguments
+                  `(#:guile ,%bootstrap-guile
+                    #:modules ((guix build utils))
+                    #:builder
+                    (begin
+                      (use-modules (guix build utils))
+                      (let* ((out (string-append (assoc-ref %outputs "out")
+                                                 "/share/guile/site/"
+                                                 (effective-version))))
+                        (mkdir-p out)
+                        (call-with-output-file (string-append out "/hg2g.scm")
+                          (lambda (port)
+                            (write '(define-module (hg2g)
+                                      #:export (the-answer))
+                                   port)
+                            (write '(define the-answer 42) port)))))))))
+
 
 (test-begin "gexp")
 
@@ -739,6 +761,54 @@
       (built-derivations (list drv))
       (return (= 42 (call-with-input-file out read))))))
 
+(test-equal "gexp-extensions & ungexp"
+  (list sed grep)
+  ((@@ (guix gexp) gexp-extensions)
+   #~(foo #$(with-extensions (list grep) #~+)
+          #+(with-extensions (list sed)  #~-))))
+
+(test-equal "gexp-extensions & ungexp-splicing"
+  (list grep sed)
+  ((@@ (guix gexp) gexp-extensions)
+   #~(foo #$@(list (with-extensions (list grep) #~+)
+                   (with-imported-modules '((foo))
+                     (with-extensions (list sed) #~-))))))
+
+(test-equal "gexp-extensions and literal Scheme object"
+  '()
+  ((@@ (guix gexp) gexp-extensions) #t))
+
+(test-assertm "gexp->derivation & with-extensions"
+  ;; Create a fake Guile extension and make sure it is accessible both to the
+  ;; imported modules and to the derivation build script.
+  (mlet* %store-monad
+      ((extension -> %extension-package)
+       (module -> (scheme-file "x" #~( ;; splice!
+                                      (define-module (foo)
+                                        #:use-module (hg2g)
+                                        #:export (multiply))
+
+                                      (define (multiply x)
+                                        (* the-answer x)))
+                               #:splice? #t))
+       (build -> (with-extensions (list extension)
+                   (with-imported-modules `((guix build utils)
+                                            ((foo) => ,module))
+                     #~(begin
+                         (use-modules (guix build utils)
+                                      (hg2g) (foo))
+                         (call-with-output-file #$output
+                           (lambda (port)
+                             (write (list the-answer (multiply 2))
+                                    port)))))))
+       (drv      (gexp->derivation "thingie" build
+                                   ;; %BOOTSTRAP-GUILE is 2.0.
+                                   #:effective-version "2.0"))
+       (out ->   (derivation->output-path drv)))
+    (mbegin %store-monad
+      (built-derivations (list drv))
+      (return (equal? '(42 84) (call-with-input-file out read))))))
+
 (test-assertm "gexp->derivation #:references-graphs"
   (mlet* %store-monad
       ((one (text-file "one" (random-text)))
@@ -948,6 +1018,22 @@
              (return (and (zero? (close-pipe pipe))
                           (string=? text str))))))))))
 
+(test-assertm "program-file & with-extensions"
+  (let* ((exp    (with-extensions (list %extension-package)
+                   (gexp (begin
+                           (use-modules (hg2g))
+                           (display the-answer)))))
+         (file   (program-file "program" exp
+                               #:guile %bootstrap-guile)))
+    (mlet* %store-monad ((drv (lower-object file))
+                         (out -> (derivation->output-path drv)))
+      (mbegin %store-monad
+        (built-derivations (list drv))
+        (let* ((pipe  (open-input-pipe out))
+               (str   (get-string-all pipe)))
+          (return (and (zero? (close-pipe pipe))
+                       (= 42 (string->number str)))))))))
+
 (test-assertm "scheme-file"
   (let* ((text   (plain-file "foo" "Hello, world!"))
          (scheme (scheme-file "bar" #~(list "foo" #$text))))