nonguix: Add with-transformation.

* nonguix/utils.scm (with-transformation): New procedure.

Signed-off-by: Hilton Chain <hako@ultrarare.space>

1 files changed, 46 insertions, 1 deletions

diff --git a/nonguix/utils.scm b/nonguix/utils.scm
index 6703f4a..4deb597 100644
--- a/nonguix/utils.scm
+++ b/nonguix/utils.scm
@@ -4,11 +4,14 @@
 
 (define-module (nonguix utils)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-43)
   #:use-module (ice-9 match)
   #:use-module (ice-9 textual-ports)
   #:use-module (ice-9 popen)
   #:use-module (guix utils)
-  #:use-module (guix packages))
+  #:use-module (guix packages)
+  #:use-module (gnu services)
+  #:export (with-transformation))
 
 (define-public (to32 package64)
   "Build package for i686-linux.
@@ -22,3 +25,45 @@ Only x86_64-linux and i686-linux are supported.
        (arguments `(#:system "i686-linux"
                     ,@(package-arguments package64)))))
     (_ package64)))
+
+;; For concerns and direction of improvement, see this thread:
+;; https://lists.gnu.org/archive/html/guix-devel/2024-06/msg00275.html
+(define* (with-transformation proc obj #:optional (pred package?))
+  "Recursing into child elements, apply PROC to every element of OBJ that
+matches PRED."
+  (match obj
+    ((? pred)
+     (proc obj))
+    ((? procedure?)
+     (lambda args
+       (apply values
+              (map (cut with-transformation proc <> pred)
+                   (call-with-values
+                       (lambda ()
+                         (apply obj args))
+                     list)))))
+    ((a . b)
+     (cons (with-transformation proc a pred)
+           (with-transformation proc b pred)))
+    ((_ ...)
+     (map (cut with-transformation proc <> pred)
+          obj))
+    (#(_ ...)
+     (vector-map (lambda (vec elt)
+                   (with-transformation proc elt pred))
+                 obj))
+    ;; `<service-type>' and `<origin>' record types are expected to not be
+    ;; modified. Altering them causes very difficult to debug run-time errors.
+    ((or (? service-type?)
+         (? origin?))
+     obj)
+    ((? record?)
+     (let* ((record-type (record-type-descriptor obj))
+            (record-fields (record-type-fields record-type)))
+       (apply (record-constructor record-type)
+              (map (lambda (field)
+                     (let* ((accessor (record-accessor record-type field))
+                            (obj (accessor obj)))
+                       (with-transformation proc obj pred)))
+                   record-fields))))
+    (_ obj)))