gexp: Add ‘with-transformation’.

4b1966c6 · Ludovic Courtès <[email protected]> · 2026-04-17 21:17:35 +02:00

* guix/gexp.scm (current-transformation): New variable.
(with-transformation, transform): New procedures.
(lower-object, lower+expand-object): Call ‘transform’ on each file-like object
and take its result.
* tests/gexp.scm ("lower-object, with-transformation")
("lower-object, with-transformation, file-append")
("lower-object, with-transformation, list"): New tests.
* doc/guix.texi (G-Expressions): Document ‘with-transformation’.

Signed-off-by: Ludovic Courtès <[email protected]>

Commit: 4b1966c6a078c1ebb59b709944e546261d66dd1d
Parents: b2067cbc

Changes

4 files changed · +156 −38

File	Status	Add	Del	Content
.dir-locals.el	modified	+2	−1	View file
doc/guix.texi	modified	+30	−0	View file
guix/gexp.scm	modified	+72	−37	View file
tests/gexp.scm	modified	+52	−0	View file

.dir-locals.el

View file

diff --git a/.dir-locals.el b/.dir-locals.el
index bbe36a0..e51d118 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012-2023 Ludovic Courtès <[email protected]>
+;;; Copyright © 2012-2023, 2026 Ludovic Courtès <[email protected]>
 ;;; Copyright © 2013,2014 Mark H Weaver <[email protected]>
 ;;; Copyright © 2014 Taylan Ulrich Bayırlı/Kammer <[email protected]>
 ;;; Copyright © 2015 David Thompson <[email protected]>
@@ -206,6 +206,7 @@
    (eval . (put 'with-imported-modules 'scheme-indent-function 1))
    (eval . (put 'with-extensions 'scheme-indent-function 1))
    (eval . (put 'with-parameters 'scheme-indent-function 1))
+   (eval . (put 'with-transformation 'scheme-indent-function 1))
    (eval . (put 'let-system 'scheme-indent-function 1))
    (eval . (put 'with-build-variables 'scheme-indent-function 2))
 

doc/guix.texi

View file

diff --git a/doc/guix.texi b/doc/guix.texi
index 2a69664..70d73af 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -13741,6 +13741,36 @@ The example above returns an object that corresponds to the i686 build
 of Coreutils, regardless of the current value of @code{%current-system}.
 @end defmac
 
+@cindex transformation, on gexps
+@cindex customization, via gexp transformation
+@deffn {Procedure} with-transformation @var{proc} @var{mval}
+Install @var{proc} as a file-like transformation procedure, and return
+@var{mval}, a value in the store monad, in this context.  @var{proc} is
+passed any file-like that gets lowered and must return another file-like
+object.  A typical use case is to replace one package by another.
+
+For example, one might replace occurrences of @code{coreutils} with
+@code{coreutils-minimal} in an operating system by doing something like
+this:
+
+@lisp
+(with-transformation (lambda (p)
+                       (if (eq? p coreutils)
+                           coreutils-minimal
+                           p))
+  (lower-object (operating-system @dots{})))
+@end lisp
+
+To modify not just the ``surface'' of things but also entire package
+dependency graph, one might instead resort to procedures like
+@code{options->transformation} as the transformation procedure
+(@pxref{Package Transformation Options}).
+
+The @code{with-transformation} procedure is the ultimate customization
+mechanism since it gets to ``see'' every file-like object that makes up
+the bigger object being lowered.
+@end deffn
+
 @defmac delayed-object @var{exp}
 This macro delays the evaluation of @var{exp} until the returned object
 is lowered to a derivation or store item.

guix/gexp.scm

View file

diff --git a/guix/gexp.scm b/guix/gexp.scm
index 7ffebec..f7eddcd 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -47,6 +47,7 @@
   #:use-module (guix utils)
   #:use-module (guix diagnostics)
   #:use-module (guix i18n)
+  #:use-module ((guix memoization) #:select (mlambdaq))
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
@@ -129,6 +130,7 @@
             lowered-gexp-guile
             lowered-gexp-load-path
             lowered-gexp-load-compiled-path
+            with-transformation
 
             with-build-variables
             input-tuples->gexp
@@ -284,6 +286,37 @@ procedure to expand it; otherwise return #f."
   (and=> (hashq-ref %gexp-compilers (struct-vtable object))
          gexp-compiler-expand))
 
+(define current-transformation
+  ;; Object-to-object transformation procedure.  This procedure is invoked for
+  ;; every file-like object that is lowered.
+  (make-parameter identity
+    (lambda (proc)
+      ;; Memoize PROC to avoid repeated calls.
+      (if (eq? proc identity)
+          identity
+          (mlambdaq (obj) (proc obj))))))
+
+(define (transform obj)
+  "Invoke the current transformation on OBJ."
+  ((current-transformation) obj))
+
+(define (with-transformation proc mval)
+  "Install PROC as a file-like transformation procedure, and return MVAL, a
+value in the store monad, in this context.  PROC is passed any file-like that
+gets lowered and must return another file-like object.  A typical use case is
+to replace one package by another."
+  ;; The object cache might contain associations that the new transformation
+  ;; invalidates.  For example, when replacing 'coreutils' by something else,
+  ;; a cached mapping for (file-append coreutils "/bin/env") becomes stale.
+  ;; Not exposing 'current-transformation' also avoids headaches related to
+  ;; dynamic scoping and dynamic-monadic scoping.
+  (state-parameterize ((current-transformation proc))
+    (clear-object-cache)
+    (mlet %store-monad ((val mval))
+      (mbegin %store-monad
+        (clear-object-cache)
+        (return val)))))
+
 (define* (lower-object obj
                        #:optional (system (%current-system))
                        #:key (target 'current))
@@ -296,21 +329,22 @@ OBJ must be an object that has an associated gexp compiler, such as a
                                   (return target)))
                       (graft? (grafting?)))
     (let loop ((obj obj))
-      (match (lookup-compiler obj)
-        (#f
-         (raise (condition (&gexp-input-error (input obj)))))
-        (lower
-         ;; Cache in STORE the result of lowering OBJ.  If OBJ is a
-         ;; derivation, bypass the cache.
-         (if (derivation? obj)
-             (return obj)
-             (mcached (mlet %store-monad ((lowered (lower obj system target)))
-                        (if (and (struct? lowered)
-                                 (not (derivation? lowered)))
-                            (loop lowered)
-                            (return lowered)))
-                      obj
-                      system target graft?)))))))
+      (let ((obj (transform obj)))
+        (match (lookup-compiler obj)
+          (#f
+           (raise (condition (&gexp-input-error (input obj)))))
+          (lower
+           ;; Cache in STORE the result of lowering OBJ.  If OBJ is a
+           ;; derivation, bypass the cache.
+           (if (derivation? obj)
+               (return obj)
+               (mcached (mlet %store-monad ((lowered (lower obj system target)))
+                          (if (and (struct? lowered)
+                                   (not (derivation? lowered)))
+                              (loop lowered)
+                              (return lowered)))
+                        obj
+                        system target graft?))))))))
 
 (define* (lower+expand-object obj
                               #:optional (system (%current-system))
@@ -318,28 +352,29 @@ OBJ must be an object that has an associated gexp compiler, such as a
   "Return as a value in %STORE-MONAD the output of object OBJ expands to for
 SYSTEM and TARGET.  Object such as <package>, <file-append>, or <plain-file>
 expand to file names, but it's possible to expand to a plain data type."
-  (let loop ((obj obj)
-             (expand (and (struct? obj) (lookup-expander obj))))
-    (match (lookup-compiler obj)
-      (#f
-       (raise (condition (&gexp-input-error (input obj)))))
-      (lower
-       (mlet* %store-monad ((graft?  (grafting?))
-                            (lowered (if (derivation? obj)
-                                         (return obj)
-                                         (mcached (lower obj system target)
-                                                  obj
-                                                  system target graft?))))
-         ;; LOWER might return something that needs to be further
-         ;; lowered.
-         (if (struct? lowered)
-             ;; If we lack an expander, delegate to that of LOWERED.
-             (if (not expand)
-                 (loop lowered (lookup-expander lowered))
-                 (return (expand obj lowered output)))
-             (if (not expand)                     ;self-quoting
-                 (return lowered)
-                 (return (expand obj lowered output)))))))))
+  (let loop ((obj obj))
+    (let* ((obj (transform obj))
+           (expand (and (struct? obj) (lookup-expander obj))))
+      (match (lookup-compiler obj)
+        (#f
+         (raise (condition (&gexp-input-error (input obj)))))
+        (lower
+         (mlet* %store-monad ((graft?  (grafting?))
+                              (lowered (if (derivation? obj)
+                                           (return obj)
+                                           (mcached (lower obj system target)
+                                                    obj
+                                                    system target graft?))))
+           ;; LOWER might return something that needs to be further
+           ;; lowered.
+           (if (struct? lowered)
+               ;; If we lack an expander, delegate to that of LOWERED.
+               (if (not expand)
+                   (loop lowered)
+                   (return (expand obj lowered output)))
+               (if (not expand)                     ;self-quoting
+                   (return lowered)
+                   (return (expand obj lowered output))))))))))
 
 (define-syntax define-gexp-compiler
   (syntax-rules (=> compiler expander)

tests/gexp.scm

View file

diff --git a/tests/gexp.scm b/tests/gexp.scm
index 2715a46..3c2e901 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -1803,6 +1803,58 @@ importing.* \\(guix config\\) from the host"
                    (not (member (derivation-file-name native) refs))
                    (member (derivation-file-name cross) refs))))))
 
+(test-assertm "lower-object, with-transformation"
+  (mlet* %store-monad ((file -> (computed-file "coreutils-transformed"
+                                               #~(symlink #$coreutils
+                                                          #$output)
+                                               #:guile %bootstrap-guile))
+                       (drv (with-transformation (lambda (obj)
+                                                   (if (eq? obj coreutils)
+                                                       grep
+                                                       obj))
+                              (lower-object file)))
+                       (bad (lower-object coreutils))
+                       (good (lower-object grep))
+                       (refs (references* (derivation-file-name drv))))
+    (return (and (member (derivation-file-name good) refs)
+                 (not (member (derivation-file-name bad) refs))))))
+
+(test-assertm "lower-object, with-transformation, file-append"
+  (mlet* %store-monad ((file -> (computed-file "coreutils-transformed"
+                                               #~(symlink
+                                                  #$(file-append coreutils
+                                                                 "/bin/true")
+                                                  #$output)
+                                               #:guile %bootstrap-guile))
+                       (drv1 (with-transformation (lambda (obj)
+                                                    (if (eq? obj coreutils)
+                                                        coreutils-minimal
+                                                        obj))
+                               (lower-object file)))
+                       (drv2 (lower-object file)) ;cache must be invalidated
+                       (bad (lower-object coreutils))
+                       (good (lower-object coreutils-minimal))
+                       (refs (references* (derivation-file-name drv1))))
+    (return (and (member (derivation-file-name good) refs)
+                 (not (member (derivation-file-name bad) refs))))))
+
+(test-assertm "lower-object, with-transformation, list"
+  (mlet* %store-monad ((file -> (computed-file "coreutils-transformed"
+                                               #~(symlink
+                                                  (car '#$(list coreutils))
+                                                  #$output)
+                                               #:guile %bootstrap-guile))
+                       (drv (with-transformation (lambda (obj)
+                                                   (if (eq? obj coreutils)
+                                                       grep
+                                                       obj))
+                              (lower-object file)))
+                       (bad (lower-object coreutils))
+                       (good (lower-object grep))
+                       (refs (references* (derivation-file-name drv))))
+    (return (and (member (derivation-file-name good) refs)
+                 (not (member (derivation-file-name bad) refs))))))
+
 (test-assertm "references-file"
   (let* ((exp      #~(symlink #$%bootstrap-guile #$output))
          (computed (computed-file "computed" exp