summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2020-09-24 22:13:06 +0200
committerLudovic Courtès <ludo@gnu.org>2020-10-02 23:28:09 +0200
commitad54a73bb820a685f242976a86be63931789fa97 (patch)
tree18b1b167bb165360b2b4799565330fca9ef9b689 /guix
parent63e5ef402b66950b8fd24ba3808c022084cdb955 (diff)
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.
Diffstat (limited to 'guix')
-rw-r--r--guix/scripts/build.scm80
-rw-r--r--guix/scripts/pack.scm29
-rw-r--r--guix/scripts/package.scm13
3 files changed, 87 insertions, 35 deletions
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 476e556618..72a5d46347 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 bab3a3e2e4..0b66da01f9 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 7e7c37eac4..83f8c123d9 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