diff options
| -rw-r--r-- | guix/gexp.scm | 83 |
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 |