01/04: guix build: Record package transformations in manifest entries.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit ad54a73bb820a685f242976a86be63931789fa97
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Thu Sep 24 22:13:06 2020 +0200

    guix build: Record package transformations in manifest entries.
    
    With this change, package transformation options used while building a
    manifest are saved in the metadata of the manifest entries.
    
    * guix/scripts/build.scm (transformation-procedure): New procedure.
    (options->transformation)[applicable]: Use it.  Change to a list of
    key/value/proc tuples instead of key/proc pairs.
    [package-with-transformation-properties, tagged-object]: New
    procedures.  Use them.
    (package-transformations, manifest-entry-with-transformations): New
    procedures.
    * guix/scripts/pack.scm (guix-pack)[with-transformations]: New
    procedure.
    Use it.
    * guix/scripts/package.scm (process-actions)[transform-entry]: Use it.
    * tests/guix-package-aliases.sh: Add test.
---
 guix/scripts/build.scm        | 80 ++++++++++++++++++++++++++++++++++---------
 guix/scripts/pack.scm         | 29 +++++++++-------
 guix/scripts/package.scm      | 13 +++----
 tests/guix-package-aliases.sh |  6 ++++
 4 files changed, 93 insertions(+), 35 deletions(-)

diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 476e556..72a5d46 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -63,6 +63,7 @@
 
             %transformation-options
             options->transformation
+            manifest-entry-with-transformations
             show-transformation-options-help
 
             guix-build
@@ -427,6 +428,14 @@ a checkout of the Git repository at the given URL."
     (with-git-url . ,transform-package-source-git-url)
     (without-tests . ,transform-package-tests)))
 
+(define (transformation-procedure key)
+  "Return the transformation procedure associated with KEY, a symbol such as
+'with-source', or #f if there is none."
+  (any (match-lambda
+         ((k . proc)
+          (and (eq? k key) proc)))
+       %transformations))
+
 (define %transformation-options
   ;; The command-line interface to the above transformations.
   (let ((parser (lambda (symbol)
@@ -481,32 +490,69 @@ derivation, etc.), applies the transformations specified 
by OPTS."
     ;; order in which they appear on the command line.
     (filter-map (match-lambda
                   ((key . value)
-                   (match (any (match-lambda
-                                 ((k . proc)
-                                  (and (eq? k key) proc)))
-                               %transformations)
+                   (match (transformation-procedure key)
                      (#f
                       #f)
                      (transform
                       ;; XXX: We used to pass TRANSFORM a list of several
                       ;; arguments, but we now pass only one, assuming that
                       ;; transform composes well.
-                      (cons key (transform (list value)))))))
+                      (list key value (transform (list value)))))))
                 (reverse opts)))
 
+  (define (package-with-transformation-properties p)
+    (package/inherit p
+      (properties `((transformations
+                     . ,(map (match-lambda
+                               ((key value _)
+                                (cons key value)))
+                             applicable))
+                    ,@(package-properties p)))))
+
   (lambda (store obj)
-    (fold (match-lambda*
-            (((name . transform) obj)
-             (let ((new (transform store obj)))
-               (when (eq? new obj)
-                 (warning (G_ "transformation '~a' had no effect on ~a~%")
-                          name
-                          (if (package? obj)
-                              (package-full-name obj)
-                              obj)))
-               new)))
-          obj
-          applicable)))
+    (define (tagged-object new)
+      (if (and (not (eq? obj new))
+               (package? new) (not (null? applicable)))
+          (package-with-transformation-properties new)
+          new))
+
+    (tagged-object
+     (fold (match-lambda*
+             (((name value transform) obj)
+              (let ((new (transform store obj)))
+                (when (eq? new obj)
+                  (warning (G_ "transformation '~a' had no effect on ~a~%")
+                           name
+                           (if (package? obj)
+                               (package-full-name obj)
+                               obj)))
+                new)))
+           obj
+           applicable))))
+
+(define (package-transformations package)
+  "Return the transformations applied to PACKAGE according to its properties."
+  (match (assq-ref (package-properties package) 'transformations)
+    (#f '())
+    (transformations transformations)))
+
+(define (manifest-entry-with-transformations entry)
+  "Return ENTRY with an additional 'transformations' property if it's not
+already there."
+  (let ((properties (manifest-entry-properties entry)))
+    (if (assq 'transformations properties)
+        entry
+        (let ((item (manifest-entry-item entry)))
+          (manifest-entry
+            (inherit entry)
+            (properties
+             (match (and (package? item)
+                         (package-transformations item))
+               ((or #f '())
+                properties)
+               (transformations
+                `((transformations . ,transformations)
+                  ,@properties)))))))))
 
 
 ;;;
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index bab3a3e..0b66da0 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -1140,19 +1140,24 @@ Create a bundle of PACKAGE.\n"))
                manifest))
             identity))
 
+      (define (with-transformations manifest)
+        (map-manifest-entries manifest-entry-with-transformations
+                              manifest))
+
       (with-provenance
-       (cond
-        ((and (not (null? manifests)) (not (null? packages)))
-         (leave (G_ "both a manifest and a package list were given~%")))
-        ((not (null? manifests))
-         (concatenate-manifests
-          (map (lambda (file)
-                 (let ((user-module (make-user-module
-                                     '((guix profiles) (gnu)))))
-                   (load* file user-module)))
-               manifests)))
-        (else
-         (packages->manifest packages))))))
+       (with-transformations
+        (cond
+         ((and (not (null? manifests)) (not (null? packages)))
+          (leave (G_ "both a manifest and a package list were given~%")))
+         ((not (null? manifests))
+          (concatenate-manifests
+           (map (lambda (file)
+                  (let ((user-module (make-user-module
+                                      '((guix profiles) (gnu)))))
+                    (load* file user-module)))
+                manifests)))
+         (else
+          (packages->manifest packages)))))))
 
   (with-error-handling
     (with-store store
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 7e7c37e..83f8c12 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -864,12 +864,13 @@ processed, #f otherwise."
 
   (define (transform-entry entry)
     (let ((item (transform store (manifest-entry-item entry))))
-      (manifest-entry
-        (inherit entry)
-        (item item)
-        (version (if (package? item)
-                     (package-version item)
-                     (manifest-entry-version entry))))))
+      (manifest-entry-with-transformations
+       (manifest-entry
+         (inherit entry)
+         (item item)
+         (version (if (package? item)
+                      (package-version item)
+                      (manifest-entry-version entry)))))))
 
   (when (equal? profile %current-profile)
     ;; Normally the daemon created %CURRENT-PROFILE when we connected, unless
diff --git a/tests/guix-package-aliases.sh b/tests/guix-package-aliases.sh
index e4ddace..311838b 100644
--- a/tests/guix-package-aliases.sh
+++ b/tests/guix-package-aliases.sh
@@ -39,6 +39,12 @@ test -x "$profile/bin/guile"
 ! guix install -r guile-bootstrap -p "$profile" --bootstrap
 test -x "$profile/bin/guile"
 
+# Use a package transformation option and make sure it's recorded.
+guix install --bootstrap guile-bootstrap -p "$profile" \
+     --with-input=libreoffice=inkscape
+test -x "$profile/bin/guile"
+grep "libreoffice=inkscape" "$profile/manifest"
+
 guix upgrade --version
 guix upgrade -n
 guix upgrade gui.e -n