gexp: Allow used modules to be specified declaratively for gexps.

This change allows specifying a gexp's dependence on arbitrary `use-modules:'
clauses.  A top-level gexp no longer needs to know whan modules all its nested
gexps need.

* guix/gexp.scm (define-module)[#:export]: Export `with-used-modules'.
  (<gexp>)[used-modules]: Add field.
  (gexp-with-hidden-inputs): Pass used modules to altered gexp object.
  (gexp-used-modules): New procedure.
  (gexp->derivation)[add-modules]: Pass used modules to altered gexp object.
  (current-used-modules): New syntax parameter.
  (with-used-modules): New syntax transformer.
  (gexp): Include used modules in new gexp object.
  (wrap-with-used-modules): New procedure.
  (input-tuples->gexp): Include empty used modules list in new gexp object.
  (outputs->gexp): Ditto.
  (sexp->gexp): Ditto.
  (gexp->script): Add appropriate `use-modules' form to generated file.
  (gexp->file): Ditto.
  [gexp-to-write]: New nested procedure.

Change-Id: I8241a9092b162da24301d2ef25bb03e9dd40c2ed

1 files changed, 64 insertions, 19 deletions

diff --git a/guix/gexp.scm b/guix/gexp.scm
index 74b4c49f90..403ecca6fe 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -5,6 +5,9 @@
 ;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;; Copyright © 2021, 2022 Maxime Devos <maximedevos@telenet.be>
+;;; Copyright © 2024 Wojtek Kosior <koszko@koszko.org>
+;;; Additions and modifications by Wojtek Kosior are additionally
+;;; dual-licensed under the Creative Commons Zero v1.0.
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -42,6 +45,7 @@
             sexp->gexp
             with-imported-modules
             with-extensions
+            with-used-modules
             let-system
             gexp->approximate-sexp
 
@@ -153,13 +157,14 @@
 
 ;; "G expressions".
 (define-record-type <gexp>
-  (make-gexp references modules extensions proc location)
+  (make-gexp references modules extensions proc location used-modules)
   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
-  (location   %gexp-location))                    ;location alist
+  (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
+  (location     %gexp-location)                   ;location alist
+  (used-modules gexp-self-used-modules))
 
 (define (gexp-location gexp)
   "Return the source code location of GEXP."
@@ -216,7 +221,8 @@ returned by 'gexp->sexp'."
              (let ((extra (length inputs)))
                (lambda args
                  (apply (gexp-proc gexp) (drop args extra))))
-             (gexp-location gexp)))
+             (gexp-location gexp)
+             (gexp-self-used-modules gexp)))
 
 
 ;;;
@@ -890,6 +896,12 @@ GEXP) is false, meaning that GEXP is a plain Scheme object, return the empty
 list."
   (gexp-attribute gexp gexp-self-extensions))
 
+(define (gexp-used-modules gexp)
+  "Return the list of `(use-modules)' clauses needed by this GEXP.  If (gexp?
+GEXP) is false, meaning that GEXP is a plain Scheme object, return the empty
+list."
+  (gexp-attribute gexp gexp-self-used-modules))
+
 (define (self-quoting? x)
   (letrec-syntax ((one-of (syntax-rules ()
                             ((_) #f)
@@ -1200,7 +1212,8 @@ The other arguments are as for 'derivation'."
                    (append modules (gexp-self-modules exp))
                    (gexp-self-extensions exp)
                    (gexp-proc exp)
-                   (gexp-location exp))))
+                   (gexp-location exp)
+                   (gexp-self-used-modules exp))))
 
   (mlet* %store-monad ( ;; The following binding forces '%current-system' and
                        ;; '%current-target-system' to be looked up at >>=
@@ -1436,6 +1449,17 @@ execution environment."
                          (identifier-syntax extensions)))
     body ...))
 
+(define-syntax-parameter current-used-modules
+  ;; Current list of `(use-modules)' clauses.
+  (identifier-syntax '()))
+
+(define-syntax-rule (with-used-modules modules body ...)
+  "Mark the gexps defined in BODY... as expecting `(use-modules)' clauses from
+MODULES to be in effect in their execution environment."
+  (syntax-parameterize ((current-used-modules
+                         (identifier-syntax modules)))
+    body ...))
+
 (define-syntax gexp
   (lambda (s)
     (define (collect-escapes exp)
@@ -1535,7 +1559,8 @@ execution environment."
                       current-imported-extensions
                       (lambda #,formals
                         #,sexp)
-                      (current-source-location)))))))
+                      (current-source-location)
+                      current-used-modules))))))
 
 
 ;;;
@@ -1841,6 +1866,24 @@ TARGET, a GNU triplet."
                             (else
                              '()))))))
 
+(define* (wrap-with-used-modules gexp-record #:optional (splice? #f))
+  "Return a gexp that also includes the appropriate `(use-modules)' clauses.
+Use `(begin)' form for this purpose unless SPLICE? is true or there are no
+clauses to include."
+  (match (list splice? (gexp-used-modules gexp-record))
+
+    ((_ ())
+     gexp-record)
+
+    ((#t used-modules)
+     (gexp ((use-modules . (ungexp used-modules))
+            . (ungexp gexp-record))))
+
+    ((#f used-modules)
+     (gexp (begin
+             (use-modules . (ungexp used-modules))
+             (ungexp gexp-record))))))
+
 
 ;;;
 ;;; Convenience procedures.
@@ -1927,7 +1970,8 @@ to an input alist."
   ;; allocations, no need to scan long list-valued <gexp-input> records in
   ;; search of file-like objects, etc.
   (make-gexp references '() '() proc
-             (source-properties inputs)))
+             (source-properties inputs)
+             '()))
 
 (define (outputs->gexp outputs)
   "Given OUTPUTS, a list of output names, return a gexp that expands to an
@@ -1942,7 +1986,8 @@ output alist."
 
   ;; This gexp is more efficient than an equivalent hand-written gexp.
   (make-gexp references '() '() proc
-             (source-properties outputs)))
+             (source-properties outputs)
+             '()))
 
 (define (with-build-variables inputs outputs body)
   "Return a gexp that surrounds BODY with a definition of the legacy
@@ -1971,7 +2016,8 @@ scanned for file-like objects, thereby reducing processing costs.  This is
 particularly useful if SEXP is a long list or a deep tree."
   (make-gexp '() '() '()
              (lambda () sexp)
-             (source-properties sexp)))
+             (source-properties sexp)
+             '()))
 
 (define* (gexp->script name exp
                        #:key (guile (default-guile))
@@ -2010,7 +2056,7 @@ imported modules in its search path.  Look up EXP's modules in MODULE-PATH."
                                 (gexp ((write '(ungexp set-load-path) port)))
                                 (gexp ())))
 
-                           (write '(ungexp exp) port)
+                           (write '(ungexp (wrap-with-used-modules exp)) port)
                            (chmod port #o555))))
                       #:system system
                       #:target target
@@ -2038,6 +2084,9 @@ When SET-LOAD-PATH? is true, emit code in the resulting file to set
 Lookup EXP's modules in MODULE-PATH."
   (define modules (gexp-modules exp))
   (define extensions (gexp-extensions exp))
+  (define gexp-to-write (if splice?
+                            (wrap-with-used-modules exp #t)
+                            (gexp ((ungexp (wrap-with-used-modules exp))))))
 
   (mlet* %store-monad
       ((target (if (eq? target 'current)
@@ -2061,9 +2110,7 @@ Lookup EXP's modules in MODULE-PATH."
                                (for-each
                                 (lambda (exp)
                                   (write exp port))
-                                '(ungexp (if splice?
-                                             exp
-                                             (gexp ((ungexp exp)))))))))
+                                '(ungexp gexp-to-write)))))
                           #:guile-for-build guile-for-build
                           #:local-build? #t
                           #:substitutable? #f
@@ -2077,9 +2124,7 @@ Lookup EXP's modules in MODULE-PATH."
                                (for-each
                                 (lambda (exp)
                                   (write exp port))
-                                '(ungexp (if splice?
-                                             exp
-                                             (gexp ((ungexp exp)))))))))
+                                '(ungexp gexp-to-write)))))
                           #:module-path module-path
                           #:guile-for-build guile-for-build
                           #:local-build? #t