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'.

1 files changed, 126 insertions, 42 deletions

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