* [bug#44321] [PATCH 2/6] guix build: Remove unnecessary (replacement #f).
2020-10-29 23:09 ` [bug#44321] [PATCH 1/6] guix build: 'package-with-source' no longer takes a 'store' parameter Ludovic Courtès
@ 2020-10-29 23:09 ` Ludovic Courtès
2020-10-29 23:09 ` [bug#44321] [PATCH 3/6] guix build: 'options->transformation' no longer takes a 'store' parameter Ludovic Courtès
` (4 subsequent siblings)
5 siblings, 0 replies; 21+ messages in thread
From: Ludovic Courtès @ 2020-10-29 23:09 UTC (permalink / raw)
To: 44321; +Cc: Ludovic Courtès
* guix/scripts/build.scm (package-with-source): Remove 'replacement'
field, which is innate since d5ec5ed7197d121130af6953378bcfd8929a9754.
---
guix/scripts/build.scm | 6 +-----
1 file changed, 1 insertion(+), 5 deletions(-)
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 831ac8f798..65a125263d 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -202,11 +202,7 @@ the new package's version number from URI."
(package-version p)))
;; Use #:recursive? #t to allow for directories.
- (source (downloaded-file uri #t))
-
- ;; Override the replacement, otherwise '--with-source' would
- ;; have no effect.
- (replacement #f)))))
+ (source (downloaded-file uri #t))))))
\f
;;;
--
2.28.0
^ permalink raw reply related [flat|nested] 21+ messages in thread* [bug#44321] [PATCH 3/6] guix build: 'options->transformation' no longer takes a 'store' parameter.
2020-10-29 23:09 ` [bug#44321] [PATCH 1/6] guix build: 'package-with-source' no longer takes a 'store' parameter Ludovic Courtès
2020-10-29 23:09 ` [bug#44321] [PATCH 2/6] guix build: Remove unnecessary (replacement #f) Ludovic Courtès
@ 2020-10-29 23:09 ` Ludovic Courtès
2020-10-30 22:27 ` Miguel Ángel Arruga Vivas
2020-10-29 23:09 ` [bug#44321] [PATCH 4/6] guix build: Move transformation options to (guix transformations) Ludovic Courtès
` (3 subsequent siblings)
5 siblings, 1 reply; 21+ messages in thread
From: Ludovic Courtès @ 2020-10-29 23:09 UTC (permalink / raw)
To: 44321; +Cc: Ludovic Courtès
* guix/scripts/build.scm (transform-package-source)
(transform-package-inputs, transform-package-inputs/graft)
(transform-package-source-branch, transform-package-source-commit)
(transform-package-source-git-url, transform-package-toolchain)
(transform-package-with-debug-info, transform-package-tests): Remove
'store' parameter.
(options->transformation, options->derivations): Adjust accordingly.
* guix/scripts/environment.scm (options/resolve-packages): Likewise.
* guix/scripts/graph.scm (guix-graph): Likewise.
* guix/scripts/pack.scm (guix-pack): Likewise.
* guix/scripts/package.scm (transaction-upgrade-entry): Likewise.
(process-actions): Likewise.
* tests/scripts-build.scm ("options->transformation, no transformations"):
Adjust test.
("options->transformation, with-source")
("options->transformation, with-source, replacement")
("options->transformation, with-source, with version")
("options->transformation, with-source, PKG=URI"): Use 'lower-object' to
compute the store file name of the source.
("options->transformation, with-source, no matches"): Remove
'with-store' and adjust accordingly.
("options->transformation, with-input"): Likewise.
("options->transformation, with-graft"): Likewise.
("options->transformation, with-branch"): Likewise.
("options->transformation, with-commit"): Likewise.
("options->transformation, with-git-url"): Likewise.
("options->transformation, with-git-url + with-branch"): Likewise.
("options->transformation, with-c-toolchain"): Likewise.
("options->transformation, with-c-toolchain twice"): Likewise.
("options->transformation, with-c-toolchain, no effect"): Likewise.
("options->transformation, with-debug-info"): Likewise.
("options->transformation, without-tests"): Likewise.
---
guix/scripts/build.scm | 25 ++--
guix/scripts/environment.scm | 2 +-
guix/scripts/graph.scm | 8 +-
guix/scripts/pack.scm | 4 +-
guix/scripts/package.scm | 4 +-
tests/scripts-build.scm | 261 +++++++++++++++++------------------
6 files changed, 148 insertions(+), 156 deletions(-)
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 65a125263d..4b86047587 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -233,7 +233,7 @@ matching URIs given in SOURCES."
(string-drop uri (+ 1 index))))))))
sources))
- (lambda (store obj)
+ (lambda (obj)
(let loop ((sources new-sources)
(result '()))
(match obj
@@ -276,7 +276,7 @@ called \"guile\" must be replaced with a dependency on a version 2.1 of
(lambda (old new)
new)))
(rewrite (package-input-rewriting/spec replacements)))
- (lambda (store obj)
+ (lambda (obj)
(if (package? obj)
(rewrite obj)
obj))))
@@ -292,7 +292,7 @@ current 'gnutls' package, after which version 3.5.4 is grafted onto them."
(let* ((replacements (evaluate-replacement-specs replacement-specs
set-replacement))
(rewrite (package-input-rewriting/spec replacements)))
- (lambda (store obj)
+ (lambda (obj)
(if (package? obj)
(rewrite obj)
obj))))
@@ -349,7 +349,7 @@ strings like \"guile-next=stable-3.0\" meaning that packages are built using
(let* ((replacements (evaluate-git-replacement-specs replacement-specs
replace))
(rewrite (package-input-rewriting/spec replacements)))
- (lambda (store obj)
+ (lambda (obj)
(if (package? obj)
(rewrite obj)
obj))))
@@ -377,7 +377,7 @@ strings like \"guile-next=cabba9e\" meaning that packages are built using
(let* ((replacements (evaluate-git-replacement-specs replacement-specs
replace))
(rewrite (package-input-rewriting/spec replacements)))
- (lambda (store obj)
+ (lambda (obj)
(if (package? obj)
(rewrite obj)
obj))))
@@ -405,7 +405,7 @@ a checkout of the Git repository at the given URL."
(define rewrite
(package-input-rewriting/spec replacements))
- (lambda (store obj)
+ (lambda (obj)
(if (package? obj)
(rewrite obj)
obj)))
@@ -478,7 +478,7 @@ the equal sign."
spec))))
replacement-specs))
- (lambda (store obj)
+ (lambda (obj)
(if (package? obj)
(or (any (match-lambda
((bottom . toolchain)
@@ -516,7 +516,7 @@ to the same package but with #:strip-binaries? #f in its 'arguments' field."
(cons spec package-with-debug-info))
specs)))
- (lambda (store obj)
+ (lambda (obj)
(if (package? obj)
(rewrite obj)
obj)))
@@ -535,7 +535,7 @@ to the same package but with #:strip-binaries? #f in its 'arguments' field."
(cons spec package-without-tests))
specs)))
- (lambda (store obj)
+ (lambda (obj)
(if (package? obj)
(rewrite obj)
obj)))
@@ -646,7 +646,7 @@ derivation, etc.), applies the transformations specified by OPTS."
applicable))
,@(package-properties p)))))
- (lambda (store obj)
+ (lambda (obj)
(define (tagged-object new)
(if (and (not (eq? obj new))
(package? new) (not (null? applicable)))
@@ -656,7 +656,7 @@ derivation, etc.), applies the transformations specified by OPTS."
(tagged-object
(fold (match-lambda*
(((name value transform) obj)
- (let ((new (transform store obj)))
+ (let ((new (transform obj)))
(when (eq? new obj)
(warning (G_ "transformation '~a' had no effect on ~a~%")
name
@@ -1113,8 +1113,7 @@ build."
(systems systems)))
(define things-to-build
- (map (cut transform store <>)
- (options->things-to-build opts)))
+ (map transform (options->things-to-build opts)))
(define (compute-derivation obj system)
;; Compute the derivation of OBJ for SYSTEM.
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 91ce2af9bb..4db6c5d2d7 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -320,7 +320,7 @@ for the corresponding packages."
(manifest-entry-output e2))))
(define transform
- (cut (options->transformation opts) store <>))
+ (options->transformation opts))
(define* (package->manifest-entry* package #:optional (output "out"))
(package->manifest-entry (transform package) output))
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index 0d11fc9795..6b2e60d7e2 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -582,11 +582,11 @@ Emit a representation of the dependency graph of PACKAGE...\n"))
(('argument . (? store-path? item))
item)
(('argument . spec)
- (transform store
- (specification->package spec)))
+ (transform
+ (specification->package spec)))
(('expression . exp)
- (transform store
- (read/eval-package-expression exp)))
+ (transform
+ (read/eval-package-expression exp)))
(_ #f))
opts)))
(run-with-store store
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index a5a70d5162..8a6aa2882b 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -1116,9 +1116,9 @@ Create a bundle of PACKAGE.\n"))
(let* ((transform (options->transformation opts))
(packages (map (match-lambda
(((? package? package) output)
- (list (transform store package) output))
+ (list (transform package) output))
((? package? package)
- (list (transform store package) "out")))
+ (list (transform package) "out")))
(reverse
(filter-map maybe-package-argument opts))))
(manifests (filter-map (match-lambda
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index ba62d98682..5599e26f5d 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -223,7 +223,7 @@ non-zero relevance score."
(($ <manifest-entry> name version output (? string? path))
(match (find-best-packages-by-name name #f)
((pkg . rest)
- (let* ((pkg (transform store pkg))
+ (let* ((pkg (transform pkg))
(candidate-version (package-version pkg)))
(match (package-superseded pkg)
((? package? new)
@@ -871,7 +871,7 @@ processed, #f otherwise."
(define transform (options->transformation opts))
(define (transform-entry entry)
- (let ((item (transform store (manifest-entry-item entry))))
+ (let ((item (transform (manifest-entry-item entry))))
(manifest-entry-with-transformations
(manifest-entry
(inherit entry)
diff --git a/tests/scripts-build.scm b/tests/scripts-build.scm
index 3a49759567..d56e02b452 100644
--- a/tests/scripts-build.scm
+++ b/tests/scripts-build.scm
@@ -19,6 +19,7 @@
(define-module (test-scripts-build)
#:use-module (guix tests)
#:use-module (guix store)
+ #:use-module ((guix gexp) #:select (lower-object))
#:use-module (guix derivations)
#:use-module (guix packages)
#:use-module (guix git-download)
@@ -42,8 +43,7 @@
(test-assert "options->transformation, no transformations"
(let ((p (dummy-package "foo"))
(t (options->transformation '())))
- (with-store store
- (eq? (t store p) p))))
+ (eq? (t p) p)))
(test-assert "options->transformation, with-source"
;; Our pseudo-package is called 'guix.scm' so the 'guix.scm' source should
@@ -52,9 +52,11 @@
(s (search-path %load-path "guix.scm"))
(t (options->transformation `((with-source . ,s)))))
(with-store store
- (let ((new (t store p)))
+ (let* ((new (t p))
+ (source (run-with-store store
+ (lower-object (package-source new)))))
(and (not (eq? new p))
- (string=? (package-source new)
+ (string=? source
(add-to-store store "guix.scm" #t
"sha256" s)))))))
@@ -64,12 +66,9 @@
(let* ((p (dummy-package "guix.scm" (replacement coreutils)))
(s (search-path %load-path "guix.scm"))
(t (options->transformation `((with-source . ,s)))))
- (with-store store
- (let ((new (t store p)))
- (and (not (eq? new p))
- (string=? (package-source new)
- (add-to-store store "guix.scm" #t "sha256" s))
- (not (package-replacement new)))))))
+ (let ((new (t p)))
+ (and (not (eq? new p))
+ (not (package-replacement new))))))
(test-assert "options->transformation, with-source, with version"
;; Our pseudo-package is called 'guix.scm' so the 'guix.scm-2.0' source
@@ -82,11 +81,13 @@
(t (options->transformation `((with-source . ,f)))))
(copy-file s f)
(with-store store
- (let ((new (t store p)))
+ (let* ((new (t p))
+ (source (run-with-store store
+ (lower-object (package-source new)))))
(and (not (eq? new p))
(string=? (package-name new) (package-name p))
(string=? (package-version new) "42.0")
- (string=? (package-source new)
+ (string=? source
(add-to-store store (basename f) #t
"sha256" f))))))))))
@@ -95,13 +96,12 @@
(let* ((p (dummy-package "foobar"))
(s (search-path %load-path "guix.scm"))
(t (options->transformation `((with-source . ,s)))))
- (with-store store
- (let* ((port (open-output-string))
- (new (parameterize ((guix-warning-port port))
- (t store p))))
- (and (eq? new p)
- (string-contains (get-output-string port)
- "had no effect"))))))
+ (let* ((port (open-output-string))
+ (new (parameterize ((guix-warning-port port))
+ (t p))))
+ (and (eq? new p)
+ (string-contains (get-output-string port)
+ "had no effect")))))
(test-assert "options->transformation, with-source, PKG=URI"
(let* ((p (dummy-package "foo"))
@@ -109,12 +109,14 @@
(f (string-append "foo=" s))
(t (options->transformation `((with-source . ,f)))))
(with-store store
- (let ((new (t store p)))
+ (let* ((new (t p))
+ (source (run-with-store store
+ (lower-object (package-source new)))))
(and (not (eq? new p))
(string=? (package-name new) (package-name p))
(string=? (package-version new)
(package-version p))
- (string=? (package-source new)
+ (string=? source
(add-to-store store (basename s) #t
"sha256" s)))))))
@@ -124,11 +126,13 @@
(f (string-append "foo@42.0=" s))
(t (options->transformation `((with-source . ,f)))))
(with-store store
- (let ((new (t store p)))
+ (let* ((new (t p))
+ (source (run-with-store store
+ (lower-object (package-source new)))))
(and (not (eq? new p))
(string=? (package-name new) (package-name p))
(string=? (package-version new) "42.0")
- (string=? (package-source new)
+ (string=? source
(add-to-store store (basename s) #t
"sha256" s)))))))
@@ -140,20 +144,19 @@
(native-inputs `(("x" ,grep)))))))))
(t (options->transformation '((with-input . "coreutils=busybox")
(with-input . "grep=findutils")))))
- (with-store store
- (let ((new (t store p)))
- (and (not (eq? new p))
- (match (package-inputs new)
- ((("foo" dep1) ("bar" dep2) ("baz" dep3))
- (and (string=? (package-full-name dep1)
- (package-full-name busybox))
- (string=? (package-full-name dep2)
- (package-full-name findutils))
- (string=? (package-name dep3) "chbouib")
- (match (package-native-inputs dep3)
- ((("x" dep))
- (string=? (package-full-name dep)
- (package-full-name findutils))))))))))))
+ (let ((new (t p)))
+ (and (not (eq? new p))
+ (match (package-inputs new)
+ ((("foo" dep1) ("bar" dep2) ("baz" dep3))
+ (and (string=? (package-full-name dep1)
+ (package-full-name busybox))
+ (string=? (package-full-name dep2)
+ (package-full-name findutils))
+ (string=? (package-name dep3) "chbouib")
+ (match (package-native-inputs dep3)
+ ((("x" dep))
+ (string=? (package-full-name dep)
+ (package-full-name findutils)))))))))))
(test-assert "options->transformation, with-graft"
(let* ((p (dummy-package "guix.scm"
@@ -161,23 +164,22 @@
("bar" ,(dummy-package "chbouib"
(native-inputs `(("x" ,grep)))))))))
(t (options->transformation '((with-graft . "grep=findutils")))))
- (with-store store
- (let ((new (t store p)))
- (and (not (eq? new p))
- (match (package-inputs new)
- ((("foo" dep1) ("bar" dep2))
- (and (string=? (package-full-name dep1)
- (package-full-name grep))
- (string=? (package-full-name (package-replacement dep1))
- (package-full-name findutils))
- (string=? (package-name dep2) "chbouib")
- (match (package-native-inputs dep2)
- ((("x" dep))
- (with-store store
- (string=? (derivation-file-name
- (package-derivation store findutils))
- (derivation-file-name
- (package-derivation store dep))))))))))))))
+ (let ((new (t p)))
+ (and (not (eq? new p))
+ (match (package-inputs new)
+ ((("foo" dep1) ("bar" dep2))
+ (and (string=? (package-full-name dep1)
+ (package-full-name grep))
+ (string=? (package-full-name (package-replacement dep1))
+ (package-full-name findutils))
+ (string=? (package-name dep2) "chbouib")
+ (match (package-native-inputs dep2)
+ ((("x" dep))
+ (with-store store
+ (string=? (derivation-file-name
+ (package-derivation store findutils))
+ (derivation-file-name
+ (package-derivation store dep)))))))))))))
(test-equal "options->transformation, with-branch"
(git-checkout (url "https://example.org")
@@ -193,15 +195,14 @@
(commit "cabba9e")))
(sha256 #f)))))))))
(t (options->transformation '((with-branch . "chbouib=devel")))))
- (with-store store
- (let ((new (t store p)))
- (and (not (eq? new p))
- (match (package-inputs new)
- ((("foo" dep1) ("bar" dep2))
- (and (string=? (package-full-name dep1)
- (package-full-name grep))
- (string=? (package-name dep2) "chbouib")
- (package-source dep2)))))))))
+ (let ((new (t p)))
+ (and (not (eq? new p))
+ (match (package-inputs new)
+ ((("foo" dep1) ("bar" dep2))
+ (and (string=? (package-full-name dep1)
+ (package-full-name grep))
+ (string=? (package-name dep2) "chbouib")
+ (package-source dep2))))))))
(test-equal "options->transformation, with-commit"
(git-checkout (url "https://example.org")
@@ -217,15 +218,14 @@
(commit "cabba9e")))
(sha256 #f)))))))))
(t (options->transformation '((with-commit . "chbouib=abcdef")))))
- (with-store store
- (let ((new (t store p)))
- (and (not (eq? new p))
- (match (package-inputs new)
- ((("foo" dep1) ("bar" dep2))
- (and (string=? (package-full-name dep1)
- (package-full-name grep))
- (string=? (package-name dep2) "chbouib")
- (package-source dep2)))))))))
+ (let ((new (t p)))
+ (and (not (eq? new p))
+ (match (package-inputs new)
+ ((("foo" dep1) ("bar" dep2))
+ (and (string=? (package-full-name dep1)
+ (package-full-name grep))
+ (string=? (package-name dep2) "chbouib")
+ (package-source dep2))))))))
(test-equal "options->transformation, with-git-url"
(let ((source (git-checkout (url "https://example.org")
@@ -236,17 +236,16 @@
("bar" ,(dummy-package "chbouib"
(native-inputs `(("x" ,grep)))))))))
(t (options->transformation '((with-git-url . "grep=https://example.org")))))
- (with-store store
- (let ((new (t store p)))
- (and (not (eq? new p))
- (match (package-inputs new)
- ((("foo" dep1) ("bar" dep2))
- (and (string=? (package-full-name dep1)
- (package-full-name grep))
- (string=? (package-name dep2) "chbouib")
- (match (package-native-inputs dep2)
- ((("x" dep3))
- (map package-source (list dep1 dep3))))))))))))
+ (let ((new (t p)))
+ (and (not (eq? new p))
+ (match (package-inputs new)
+ ((("foo" dep1) ("bar" dep2))
+ (and (string=? (package-full-name dep1)
+ (package-full-name grep))
+ (string=? (package-name dep2) "chbouib")
+ (match (package-native-inputs dep2)
+ ((("x" dep3))
+ (map package-source (list dep1 dep3)))))))))))
(test-equal "options->transformation, with-git-url + with-branch"
;; Combine the two options and make sure the 'with-branch' transformation
@@ -263,16 +262,15 @@
(reverse '((with-git-url
. "grep=https://example.org")
(with-branch . "grep=BRANCH"))))))
- (with-store store
- (let ((new (t store p)))
- (and (not (eq? new p))
- (match (package-inputs new)
- ((("foo" dep1) ("bar" dep2))
- (and (string=? (package-name dep1) "grep")
- (string=? (package-name dep2) "chbouib")
- (match (package-native-inputs dep2)
- ((("x" dep3))
- (map package-source (list dep1 dep3))))))))))))
+ (let ((new (t p)))
+ (and (not (eq? new p))
+ (match (package-inputs new)
+ ((("foo" dep1) ("bar" dep2))
+ (and (string=? (package-name dep1) "grep")
+ (string=? (package-name dep2) "chbouib")
+ (match (package-native-inputs dep2)
+ ((("x" dep3))
+ (map package-source (list dep1 dep3)))))))))))
(define* (depends-on-toolchain? p #:optional (toolchain "gcc-toolchain"))
"Return true if P depends on TOOLCHAIN instead of the default tool chain."
@@ -302,21 +300,20 @@
;; Here we check that the transformation applies to DEP0 and all its
;; dependents: DEP0 must use GCC-TOOLCHAIN, DEP1 must use GCC-TOOLCHAIN
;; and the DEP0 that uses GCC-TOOLCHAIN, and so on.
- (with-store store
- (let ((new (t store p)))
- (and (depends-on-toolchain? new "gcc-toolchain")
- (match (bag-build-inputs (package->bag new))
- ((("foo" dep0) ("bar" dep1) _ ...)
- (and (depends-on-toolchain? dep1 "gcc-toolchain")
- (not (depends-on-toolchain? dep0 "gcc-toolchain"))
- (string=? (package-full-name dep0)
- (package-full-name grep))
- (match (bag-build-inputs (package->bag dep1))
- ((("x" dep) _ ...)
- (and (depends-on-toolchain? dep "gcc-toolchain")
- (match (bag-build-inputs (package->bag dep))
- ((("y" dep) _ ...) ;this one is unchanged
- (eq? dep grep))))))))))))))
+ (let ((new (t p)))
+ (and (depends-on-toolchain? new "gcc-toolchain")
+ (match (bag-build-inputs (package->bag new))
+ ((("foo" dep0) ("bar" dep1) _ ...)
+ (and (depends-on-toolchain? dep1 "gcc-toolchain")
+ (not (depends-on-toolchain? dep0 "gcc-toolchain"))
+ (string=? (package-full-name dep0)
+ (package-full-name grep))
+ (match (bag-build-inputs (package->bag dep1))
+ ((("x" dep) _ ...)
+ (and (depends-on-toolchain? dep "gcc-toolchain")
+ (match (bag-build-inputs (package->bag dep))
+ ((("y" dep) _ ...) ;this one is unchanged
+ (eq? dep grep)))))))))))))
(test-equal "options->transformation, with-c-toolchain twice"
(package-full-name grep)
@@ -330,23 +327,21 @@
(t (options->transformation
'((with-c-toolchain . "chbouib=clang-toolchain")
(with-c-toolchain . "stuff=clang-toolchain")))))
- (with-store store
- (let ((new (t store p)))
- (and (depends-on-toolchain? new "clang-toolchain")
- (match (bag-build-inputs (package->bag new))
- ((("foo" dep0) ("bar" dep1) ("baz" dep2) _ ...)
- (and (depends-on-toolchain? dep0 "clang-toolchain")
- (depends-on-toolchain? dep1 "clang-toolchain")
- (not (depends-on-toolchain? dep2 "clang-toolchain"))
- (package-full-name dep2)))))))))
+ (let ((new (t p)))
+ (and (depends-on-toolchain? new "clang-toolchain")
+ (match (bag-build-inputs (package->bag new))
+ ((("foo" dep0) ("bar" dep1) ("baz" dep2) _ ...)
+ (and (depends-on-toolchain? dep0 "clang-toolchain")
+ (depends-on-toolchain? dep1 "clang-toolchain")
+ (not (depends-on-toolchain? dep2 "clang-toolchain"))
+ (package-full-name dep2))))))))
(test-assert "options->transformation, with-c-toolchain, no effect"
(let ((p (dummy-package "thingie"))
(t (options->transformation
'((with-c-toolchain . "does-not-exist=gcc-toolchain")))))
;; When it has no effect, '--with-c-toolchain' returns P.
- (with-store store
- (eq? (t store p) p))))
+ (eq? (t p) p)))
(test-equal "options->transformation, with-debug-info"
'(#:strip-binaries? #f)
@@ -357,13 +352,12 @@
("bar" ,grep)))))
(t (options->transformation
'((with-debug-info . "chbouib")))))
- (with-store store
- (let ((new (t store p)))
- (match (package-inputs new)
- ((("foo" dep0) ("bar" dep1))
- (and (string=? (package-full-name dep1)
- (package-full-name grep))
- (package-arguments (package-replacement dep0)))))))))
+ (let ((new (t p)))
+ (match (package-inputs new)
+ ((("foo" dep0) ("bar" dep1))
+ (and (string=? (package-full-name dep1)
+ (package-full-name grep))
+ (package-arguments (package-replacement dep0))))))))
(test-assert "options->transformation, without-tests"
(let* ((dep (dummy-package "dep"))
@@ -371,14 +365,13 @@
(inputs `(("dep" ,dep)))))
(t (options->transformation '((without-tests . "dep")
(without-tests . "tar")))))
- (with-store store
- (let ((new (t store p)))
- (match (bag-direct-inputs (package->bag new))
- ((("dep" dep) ("tar" tar) _ ...)
- ;; TODO: Check whether TAR has #:tests? #f when transformations
- ;; apply to implicit inputs.
- (equal? (package-arguments dep)
- '(#:tests? #f))))))))
+ (let ((new (t p)))
+ (match (bag-direct-inputs (package->bag new))
+ ((("dep" dep) ("tar" tar) _ ...)
+ ;; TODO: Check whether TAR has #:tests? #f when transformations
+ ;; apply to implicit inputs.
+ (equal? (package-arguments dep)
+ '(#:tests? #f)))))))
(test-end)
--
2.28.0
^ permalink raw reply related [flat|nested] 21+ messages in thread* [bug#44321] [PATCH 3/6] guix build: 'options->transformation' no longer takes a 'store' parameter.
2020-10-29 23:09 ` [bug#44321] [PATCH 3/6] guix build: 'options->transformation' no longer takes a 'store' parameter Ludovic Courtès
@ 2020-10-30 22:27 ` Miguel Ángel Arruga Vivas
2020-10-31 10:03 ` Ludovic Courtès
0 siblings, 1 reply; 21+ messages in thread
From: Miguel Ángel Arruga Vivas @ 2020-10-30 22:27 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 44321
[-- Attachment #1: Type: text/plain, Size: 1447 bytes --]
Hi Ludo,
I just have one comment here:
Ludovic Courtès <ludo@gnu.org> writes:
> ("options->transformation, with-source")
> ("options->transformation, with-source, replacement")
> ("options->transformation, with-source, with version")
> ("options->transformation, with-source, PKG=URI"): Use 'lower-object' to
> compute the store file name of the source.
[...]
> @@ -64,12 +66,9 @@
> (let* ((p (dummy-package "guix.scm" (replacement coreutils)))
> (s (search-path %load-path "guix.scm"))
> (t (options->transformation `((with-source . ,s)))))
> - (with-store store
> - (let ((new (t store p)))
> - (and (not (eq? new p))
> - (string=? (package-source new)
> - (add-to-store store "guix.scm" #t "sha256" s))
> - (not (package-replacement new)))))))
> + (let ((new (t p)))
> + (and (not (eq? new p))
> + (not (package-replacement new))))))
>
> (test-assert "options->transformation, with-source, with version"
> ;; Our pseudo-package is called 'guix.scm' so the 'guix.scm-2.0' source
It's the only one that doesn't follow the same pattern as others, where
the change look quite similar: instead of (t store p) -> (t p) (source
(run-...)), also specified in the message.
If removing that comparison is intended, I think the commit message
should be changed. Otherwise it LGTM.
Happy hacking!
Miguel
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 658 bytes --]
^ permalink raw reply [flat|nested] 21+ messages in thread* [bug#44321] [PATCH 3/6] guix build: 'options->transformation' no longer takes a 'store' parameter.
2020-10-30 22:27 ` Miguel Ángel Arruga Vivas
@ 2020-10-31 10:03 ` Ludovic Courtès
0 siblings, 0 replies; 21+ messages in thread
From: Ludovic Courtès @ 2020-10-31 10:03 UTC (permalink / raw)
To: Miguel Ángel Arruga Vivas; +Cc: 44321
Hi Miguel,
Miguel Ángel Arruga Vivas <rosen644835@gmail.com> skribis:
> Ludovic Courtès <ludo@gnu.org> writes:
>> ("options->transformation, with-source")
>> ("options->transformation, with-source, replacement")
>> ("options->transformation, with-source, with version")
>> ("options->transformation, with-source, PKG=URI"): Use 'lower-object' to
>> compute the store file name of the source.
> [...]
>> @@ -64,12 +66,9 @@
>> (let* ((p (dummy-package "guix.scm" (replacement coreutils)))
>> (s (search-path %load-path "guix.scm"))
>> (t (options->transformation `((with-source . ,s)))))
>> - (with-store store
>> - (let ((new (t store p)))
>> - (and (not (eq? new p))
>> - (string=? (package-source new)
>> - (add-to-store store "guix.scm" #t "sha256" s))
>> - (not (package-replacement new)))))))
>> + (let ((new (t p)))
>> + (and (not (eq? new p))
>> + (not (package-replacement new))))))
>>
>> (test-assert "options->transformation, with-source, with version"
>> ;; Our pseudo-package is called 'guix.scm' so the 'guix.scm-2.0' source
>
> It's the only one that doesn't follow the same pattern as others, where
> the change look quite similar: instead of (t store p) -> (t p) (source
> (run-...)), also specified in the message.
>
> If removing that comparison is intended, I think the commit message
> should be changed. Otherwise it LGTM.
Good catch! I guess I was hesitant here. I’ll re-introduce the test
using ‘run-with-store’ and all.
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 21+ messages in thread
* [bug#44321] [PATCH 4/6] guix build: Move transformation options to (guix transformations).
2020-10-29 23:09 ` [bug#44321] [PATCH 1/6] guix build: 'package-with-source' no longer takes a 'store' parameter Ludovic Courtès
2020-10-29 23:09 ` [bug#44321] [PATCH 2/6] guix build: Remove unnecessary (replacement #f) Ludovic Courtès
2020-10-29 23:09 ` [bug#44321] [PATCH 3/6] guix build: 'options->transformation' no longer takes a 'store' parameter Ludovic Courtès
@ 2020-10-29 23:09 ` Ludovic Courtès
2020-10-30 23:03 ` Miguel Ángel Arruga Vivas
2020-10-29 23:09 ` [bug#44321] [PATCH 5/6] transformations: Raise '&formatted-message' exceptions instead of 'leave' Ludovic Courtès
` (2 subsequent siblings)
5 siblings, 1 reply; 21+ messages in thread
From: Ludovic Courtès @ 2020-10-29 23:09 UTC (permalink / raw)
To: 44321; +Cc: Ludovic Courtès
* guix/transformations.scm: New file.
* tests/scripts-build.scm: Rename to...
* tests/transformations.scm: ... this.
* Makefile.am (MODULES): Add 'guix/transformations.scm'.
(SCM_TESTS): Adjust to rename.
* guix/scripts/build.scm (numeric-extension?)
(tarball-base-name, <downloaded-file>, download-to-store*)
(compile-downloaded-file, package-with-source)
(transform-package-source, evaluate-replacement-specs)
(transform-package-inputs, transform-package-inputs/graft)
(%not-equal, package-git-url, evaluate-git-replacement-specs)
(transform-package-source-branch, transform-package-source-commit)
(transform-package-source-git-url, package-dependents/spec)
(package-toolchain-rewriting, transform-package-toolchain)
(transform-package-with-debug-info, transform-package-tests)
(%transformations, transformation-procedure, %transformation-options)
(show-transformation-options-help, options->transformation)
(package-transformations): Move to (guix transformations).
* guix/scripts/environment.scm: Adjust accordingly.
* guix/scripts/graph.scm: Likewise.
* guix/scripts/install.scm: Likewise.
* guix/scripts/pack.scm: Likewise.
* guix/scripts/package.scm: Likewise.
* guix/scripts/upgrade.scm: Likewise.
---
Makefile.am | 3 +-
guix/scripts/build.scm | 553 +---------------
guix/scripts/environment.scm | 1 +
guix/scripts/graph.scm | 5 +-
guix/scripts/install.scm | 1 +
guix/scripts/pack.scm | 1 +
guix/scripts/package.scm | 1 +
guix/scripts/upgrade.scm | 1 +
guix/transformations.scm | 610 ++++++++++++++++++
...{scripts-build.scm => transformations.scm} | 6 +-
10 files changed, 624 insertions(+), 558 deletions(-)
create mode 100644 guix/transformations.scm
rename tests/{scripts-build.scm => transformations.scm} (99%)
diff --git a/Makefile.am b/Makefile.am
index f3eb681a2b..e7053ee4f4 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -105,6 +105,7 @@ MODULES = \
guix/derivations.scm \
guix/grafts.scm \
guix/repl.scm \
+ guix/transformations.scm \
guix/inferior.scm \
guix/describe.scm \
guix/quirks.scm \
@@ -456,7 +457,6 @@ SCM_TESTS = \
tests/pypi.scm \
tests/records.scm \
tests/scripts.scm \
- tests/scripts-build.scm \
tests/search-paths.scm \
tests/services.scm \
tests/services/linux.scm \
@@ -473,6 +473,7 @@ SCM_TESTS = \
tests/syscalls.scm \
tests/system.scm \
tests/texlive.scm \
+ tests/transformations.scm \
tests/ui.scm \
tests/union.scm \
tests/upstream.scm \
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 4b86047587..e9de97c881 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -31,11 +31,6 @@
#:use-module (guix utils)
- ;; Use the procedure that destructures "NAME-VERSION" forms.
- #:use-module ((guix build utils)
- #:select ((package-name->name+version
- . hyphen-package-name->name+version)))
-
#:use-module (guix monads)
#:use-module (guix gexp)
#:use-module (guix profiles)
@@ -52,21 +47,15 @@
#:use-module (srfi srfi-35)
#:use-module (srfi srfi-37)
#:use-module (gnu packages)
- #:autoload (guix download) (download-to-store)
- #:autoload (guix git-download) (git-reference? git-reference-url)
- #:autoload (guix git) (git-checkout git-checkout? git-checkout-url)
#:use-module ((guix status) #:select (with-status-verbosity))
#:use-module ((guix progress) #:select (current-terminal-columns))
#:use-module ((guix build syscalls) #:select (terminal-columns))
+ #:use-module (guix transformations)
#:export (%standard-build-options
set-build-options-from-command-line
set-build-options-from-command-line*
show-build-options-help
- %transformation-options
- options->transformation
- manifest-entry-with-transformations
-
guix-build
register-root
register-root*))
@@ -151,546 +140,6 @@ found. Return #f if no build log was found."
(define register-root*
(store-lift register-root))
-(define (numeric-extension? file-name)
- "Return true if FILE-NAME ends with digits."
- (string-every char-set:hex-digit (file-extension file-name)))
-
-(define (tarball-base-name file-name)
- "Return the \"base\" of FILE-NAME, removing '.tar.gz' or similar
-extensions."
- ;; TODO: Factorize.
- (cond ((not (file-extension file-name))
- file-name)
- ((numeric-extension? file-name)
- file-name)
- ((string=? (file-extension file-name) "tar")
- (file-sans-extension file-name))
- ((file-extension file-name)
- =>
- (match-lambda
- ("scm" file-name)
- (else (tarball-base-name (file-sans-extension file-name)))))
- (else
- file-name)))
-
-
-;; Files to be downloaded.
-(define-record-type <downloaded-file>
- (downloaded-file uri recursive?)
- downloaded-file?
- (uri downloaded-file-uri)
- (recursive? downloaded-file-recursive?))
-
-(define download-to-store*
- (store-lift download-to-store))
-
-(define-gexp-compiler (compile-downloaded-file (file <downloaded-file>)
- system target)
- "Download FILE and return the result as a store item."
- (match file
- (($ <downloaded-file> uri recursive?)
- (download-to-store* uri #:recursive? recursive?))))
-
-(define* (package-with-source p uri #:optional version)
- "Return a package based on P but with its source taken from URI. Extract
-the new package's version number from URI."
- (let ((base (tarball-base-name (basename uri))))
- (let-values (((_ version*)
- (hyphen-package-name->name+version base)))
- (package (inherit p)
- (version (or version version*
- (package-version p)))
-
- ;; Use #:recursive? #t to allow for directories.
- (source (downloaded-file uri #t))))))
-
-\f
-;;;
-;;; Transformations.
-;;;
-
-(define (transform-package-source sources)
- "Return a transformation procedure that replaces package sources with the
-matching URIs given in SOURCES."
- (define new-sources
- (map (lambda (uri)
- (match (string-index uri #\=)
- (#f
- ;; Determine the package name and version from URI.
- (call-with-values
- (lambda ()
- (hyphen-package-name->name+version
- (tarball-base-name (basename uri))))
- (lambda (name version)
- (list name version uri))))
- (index
- ;; What's before INDEX is a "PKG@VER" or "PKG" spec.
- (call-with-values
- (lambda ()
- (package-name->name+version (string-take uri index)))
- (lambda (name version)
- (list name version
- (string-drop uri (+ 1 index))))))))
- sources))
-
- (lambda (obj)
- (let loop ((sources new-sources)
- (result '()))
- (match obj
- ((? package? p)
- (match (assoc-ref sources (package-name p))
- ((version source)
- (package-with-source p source version))
- (#f
- p)))
- (_
- obj)))))
-
-(define (evaluate-replacement-specs specs proc)
- "Parse SPECS, a list of strings like \"guile=guile@2.1\" and return a list
-of package spec/procedure pairs as expected by 'package-input-rewriting/spec'.
-PROC is called with the package to be replaced and its replacement according
-to SPECS. Raise an error if an element of SPECS uses invalid syntax, or if a
-package it refers to could not be found."
- (define not-equal
- (char-set-complement (char-set #\=)))
-
- (map (lambda (spec)
- (match (string-tokenize spec not-equal)
- ((spec new)
- (cons spec
- (let ((new (specification->package new)))
- (lambda (old)
- (proc old new)))))
- (x
- (leave (G_ "invalid replacement specification: ~s~%") spec))))
- specs))
-
-(define (transform-package-inputs replacement-specs)
- "Return a procedure that, when passed a package, replaces its direct
-dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
-strings like \"guile=guile@2.1\" meaning that, any dependency on a package
-called \"guile\" must be replaced with a dependency on a version 2.1 of
-\"guile\"."
- (let* ((replacements (evaluate-replacement-specs replacement-specs
- (lambda (old new)
- new)))
- (rewrite (package-input-rewriting/spec replacements)))
- (lambda (obj)
- (if (package? obj)
- (rewrite obj)
- obj))))
-
-(define (transform-package-inputs/graft replacement-specs)
- "Return a procedure that, when passed a package, replaces its direct
-dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
-strings like \"gnutls=gnutls@3.5.4\" meaning that packages are built using the
-current 'gnutls' package, after which version 3.5.4 is grafted onto them."
- (define (set-replacement old new)
- (package (inherit old) (replacement new)))
-
- (let* ((replacements (evaluate-replacement-specs replacement-specs
- set-replacement))
- (rewrite (package-input-rewriting/spec replacements)))
- (lambda (obj)
- (if (package? obj)
- (rewrite obj)
- obj))))
-
-(define %not-equal
- (char-set-complement (char-set #\=)))
-
-(define (package-git-url package)
- "Return the URL of the Git repository for package, or raise an error if
-the source of PACKAGE is not fetched from a Git repository."
- (let ((source (package-source package)))
- (cond ((and (origin? source)
- (git-reference? (origin-uri source)))
- (git-reference-url (origin-uri source)))
- ((git-checkout? source)
- (git-checkout-url source))
- (else
- (leave (G_ "the source of ~a is not a Git reference~%")
- (package-full-name package))))))
-
-(define (evaluate-git-replacement-specs specs proc)
- "Parse SPECS, a list of strings like \"guile=stable-2.2\", and return a list
-of package pairs, where (PROC PACKAGE URL BRANCH-OR-COMMIT) returns the
-replacement package. Raise an error if an element of SPECS uses invalid
-syntax, or if a package it refers to could not be found."
- (map (lambda (spec)
- (match (string-tokenize spec %not-equal)
- ((spec branch-or-commit)
- (define (replace old)
- (let* ((source (package-source old))
- (url (package-git-url old)))
- (proc old url branch-or-commit)))
-
- (cons spec replace))
- (x
- (leave (G_ "invalid replacement specification: ~s~%") spec))))
- specs))
-
-(define (transform-package-source-branch replacement-specs)
- "Return a procedure that, when passed a package, replaces its direct
-dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
-strings like \"guile-next=stable-3.0\" meaning that packages are built using
-'guile-next' from the latest commit on its 'stable-3.0' branch."
- (define (replace old url branch)
- (package
- (inherit old)
- (version (string-append "git." (string-map (match-lambda
- (#\/ #\-)
- (chr chr))
- branch)))
- (source (git-checkout (url url) (branch branch)
- (recursive? #t)))))
-
- (let* ((replacements (evaluate-git-replacement-specs replacement-specs
- replace))
- (rewrite (package-input-rewriting/spec replacements)))
- (lambda (obj)
- (if (package? obj)
- (rewrite obj)
- obj))))
-
-(define (transform-package-source-commit replacement-specs)
- "Return a procedure that, when passed a package, replaces its direct
-dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
-strings like \"guile-next=cabba9e\" meaning that packages are built using
-'guile-next' from commit 'cabba9e'."
- (define (replace old url commit)
- (package
- (inherit old)
- (version (if (and (> (string-length commit) 1)
- (string-prefix? "v" commit)
- (char-set-contains? char-set:digit
- (string-ref commit 1)))
- (string-drop commit 1) ;looks like a tag like "v1.0"
- (string-append "git."
- (if (< (string-length commit) 7)
- commit
- (string-take commit 7)))))
- (source (git-checkout (url url) (commit commit)
- (recursive? #t)))))
-
- (let* ((replacements (evaluate-git-replacement-specs replacement-specs
- replace))
- (rewrite (package-input-rewriting/spec replacements)))
- (lambda (obj)
- (if (package? obj)
- (rewrite obj)
- obj))))
-
-(define (transform-package-source-git-url replacement-specs)
- "Return a procedure that, when passed a package, replaces its dependencies
-according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of strings like
-\"guile-json=https://gitthing.com/…\" meaning that packages are built using
-a checkout of the Git repository at the given URL."
- (define replacements
- (map (lambda (spec)
- (match (string-tokenize spec %not-equal)
- ((spec url)
- (cons spec
- (lambda (old)
- (package
- (inherit old)
- (source (git-checkout (url url)
- (recursive? #t)))))))
- (_
- (leave (G_ "~a: invalid Git URL replacement specification~%")
- spec))))
- replacement-specs))
-
- (define rewrite
- (package-input-rewriting/spec replacements))
-
- (lambda (obj)
- (if (package? obj)
- (rewrite obj)
- obj)))
-
-(define (package-dependents/spec top bottom)
- "Return the list of dependents of BOTTOM, a spec string, that are also
-dependencies of TOP, a package."
- (define-values (name version)
- (package-name->name+version bottom))
-
- (define dependent?
- (mlambda (p)
- (and (package? p)
- (or (and (string=? name (package-name p))
- (or (not version)
- (version-prefix? version (package-version p))))
- (match (bag-direct-inputs (package->bag p))
- (((labels dependencies . _) ...)
- (any dependent? dependencies)))))))
-
- (filter dependent? (package-closure (list top))))
-
-(define (package-toolchain-rewriting p bottom toolchain)
- "Return a procedure that, when passed a package that's either BOTTOM or one
-of its dependents up to P so, changes it so it is built with TOOLCHAIN.
-TOOLCHAIN must be an input list."
- (define rewriting-property
- (gensym " package-toolchain-rewriting"))
-
- (match (package-dependents/spec p bottom)
- (() ;P does not depend on BOTTOM
- identity)
- (set
- ;; SET is the list of packages "between" P and BOTTOM (included) whose
- ;; toolchain needs to be changed.
- (package-mapping (lambda (p)
- (if (or (assq rewriting-property
- (package-properties p))
- (not (memq p set)))
- p
- (let ((p (package-with-c-toolchain p toolchain)))
- (package/inherit p
- (properties `((,rewriting-property . #t)
- ,@(package-properties p)))))))
- (lambda (p)
- (or (assq rewriting-property (package-properties p))
- (not (memq p set))))
- #:deep? #t))))
-
-(define (transform-package-toolchain replacement-specs)
- "Return a procedure that, when passed a package, changes its toolchain or
-that of its dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is
-a list of strings like \"fftw=gcc-toolchain@10\" meaning that the package to
-the left of the equal sign must be built with the toolchain to the right of
-the equal sign."
- (define split-on-commas
- (cute string-tokenize <> (char-set-complement (char-set #\,))))
-
- (define (specification->input spec)
- (let ((package (specification->package spec)))
- (list (package-name package) package)))
-
- (define replacements
- (map (lambda (spec)
- (match (string-tokenize spec %not-equal)
- ((spec (= split-on-commas toolchain))
- (cons spec (map specification->input toolchain)))
- (_
- (leave (G_ "~a: invalid toolchain replacement specification~%")
- spec))))
- replacement-specs))
-
- (lambda (obj)
- (if (package? obj)
- (or (any (match-lambda
- ((bottom . toolchain)
- ((package-toolchain-rewriting obj bottom toolchain) obj)))
- replacements)
- obj)
- obj)))
-
-(define (transform-package-with-debug-info specs)
- "Return a procedure that, when passed a package, set its 'replacement' field
-to the same package but with #:strip-binaries? #f in its 'arguments' field."
- (define (non-stripped p)
- (package
- (inherit p)
- (arguments
- (substitute-keyword-arguments (package-arguments p)
- ((#:strip-binaries? _ #f) #f)))))
-
- (define (package-with-debug-info p)
- (if (member "debug" (package-outputs p))
- p
- (let loop ((p p))
- (match (package-replacement p)
- (#f
- (package
- (inherit p)
- (replacement (non-stripped p))))
- (next
- (package
- (inherit p)
- (replacement (loop next))))))))
-
- (define rewrite
- (package-input-rewriting/spec (map (lambda (spec)
- (cons spec package-with-debug-info))
- specs)))
-
- (lambda (obj)
- (if (package? obj)
- (rewrite obj)
- obj)))
-
-(define (transform-package-tests specs)
- "Return a procedure that, when passed a package, sets #:tests? #f in its
-'arguments' field."
- (define (package-without-tests p)
- (package/inherit p
- (arguments
- (substitute-keyword-arguments (package-arguments p)
- ((#:tests? _ #f) #f)))))
-
- (define rewrite
- (package-input-rewriting/spec (map (lambda (spec)
- (cons spec package-without-tests))
- specs)))
-
- (lambda (obj)
- (if (package? obj)
- (rewrite obj)
- obj)))
-
-(define %transformations
- ;; Transformations that can be applied to things to build. The car is the
- ;; key used in the option alist, and the cdr is the transformation
- ;; procedure; it is called with two arguments: the store, and a list of
- ;; things to build.
- `((with-source . ,transform-package-source)
- (with-input . ,transform-package-inputs)
- (with-graft . ,transform-package-inputs/graft)
- (with-branch . ,transform-package-source-branch)
- (with-commit . ,transform-package-source-commit)
- (with-git-url . ,transform-package-source-git-url)
- (with-c-toolchain . ,transform-package-toolchain)
- (with-debug-info . ,transform-package-with-debug-info)
- (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)
- (lambda (opt name arg result . rest)
- (apply values
- (alist-cons symbol arg result)
- rest)))))
- (list (option '("with-source") #t #f
- (parser 'with-source))
- (option '("with-input") #t #f
- (parser 'with-input))
- (option '("with-graft") #t #f
- (parser 'with-graft))
- (option '("with-branch") #t #f
- (parser 'with-branch))
- (option '("with-commit") #t #f
- (parser 'with-commit))
- (option '("with-git-url") #t #f
- (parser 'with-git-url))
- (option '("with-c-toolchain") #t #f
- (parser 'with-c-toolchain))
- (option '("with-debug-info") #t #f
- (parser 'with-debug-info))
- (option '("without-tests") #t #f
- (parser 'without-tests)))))
-
-(define (show-transformation-options-help)
- (display (G_ "
- --with-source=[PACKAGE=]SOURCE
- use SOURCE when building the corresponding package"))
- (display (G_ "
- --with-input=PACKAGE=REPLACEMENT
- replace dependency PACKAGE by REPLACEMENT"))
- (display (G_ "
- --with-graft=PACKAGE=REPLACEMENT
- graft REPLACEMENT on packages that refer to PACKAGE"))
- (display (G_ "
- --with-branch=PACKAGE=BRANCH
- build PACKAGE from the latest commit of BRANCH"))
- (display (G_ "
- --with-commit=PACKAGE=COMMIT
- build PACKAGE from COMMIT"))
- (display (G_ "
- --with-git-url=PACKAGE=URL
- build PACKAGE from the repository at URL"))
- (display (G_ "
- --with-c-toolchain=PACKAGE=TOOLCHAIN
- build PACKAGE and its dependents with TOOLCHAIN"))
- (display (G_ "
- --with-debug-info=PACKAGE
- build PACKAGE and preserve its debug info"))
- (display (G_ "
- --without-tests=PACKAGE
- build PACKAGE without running its tests")))
-
-
-(define (options->transformation opts)
- "Return a procedure that, when passed an object to build (package,
-derivation, etc.), applies the transformations specified by OPTS."
- (define applicable
- ;; List of applicable transformations as symbol/procedure pairs in the
- ;; order in which they appear on the command line.
- (filter-map (match-lambda
- ((key . value)
- (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.
- (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 (obj)
- (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 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)))))))))
-
\f
;;;
;;; Standard command-line build options.
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 4db6c5d2d7..2328df98b8 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -32,6 +32,7 @@
#:use-module ((guix gexp) #:select (lower-object))
#:use-module (guix scripts)
#:use-module (guix scripts build)
+ #:use-module (guix transformations)
#:use-module (gnu build linux-container)
#:use-module (gnu build accounts)
#:use-module ((guix build syscalls) #:select (set-network-interface-up))
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index 6b2e60d7e2..6874904deb 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -34,10 +34,11 @@
#:use-module (guix sets)
#:use-module ((guix diagnostics)
#:select (location-file formatted-message))
- #:use-module ((guix scripts build)
+ #:use-module ((guix transformations)
#:select (options->transformation
- %standard-build-options
%transformation-options))
+ #:use-module ((guix scripts build)
+ #:select (%standard-build-options))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
diff --git a/guix/scripts/install.scm b/guix/scripts/install.scm
index 5aafe3bd6d..82f5875dd1 100644
--- a/guix/scripts/install.scm
+++ b/guix/scripts/install.scm
@@ -20,6 +20,7 @@
#:use-module (guix ui)
#:use-module (guix scripts package)
#:use-module (guix scripts build)
+ #:use-module (guix transformations)
#:use-module (guix scripts)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 8a6aa2882b..2e4daa469f 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -42,6 +42,7 @@
#:use-module (guix search-paths)
#:use-module (guix build-system gnu)
#:use-module (guix scripts build)
+ #:use-module (guix transformations)
#:use-module ((guix self) #:select (make-config.scm))
#:use-module (gnu packages)
#:use-module (gnu packages bootstrap)
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 5599e26f5d..eb2e67a0de 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -41,6 +41,7 @@
#:use-module (guix config)
#:use-module (guix scripts)
#:use-module (guix scripts build)
+ #:use-module (guix transformations)
#:use-module (guix describe)
#:autoload (guix store roots) (gc-roots user-owned?)
#:use-module ((guix build utils)
diff --git a/guix/scripts/upgrade.scm b/guix/scripts/upgrade.scm
index c4527d56d9..1ee8937acf 100644
--- a/guix/scripts/upgrade.scm
+++ b/guix/scripts/upgrade.scm
@@ -21,6 +21,7 @@
#:use-module (guix ui)
#:use-module (guix scripts package)
#:use-module (guix scripts build)
+ #:use-module (guix transformations)
#:use-module (guix scripts)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
diff --git a/guix/transformations.scm b/guix/transformations.scm
new file mode 100644
index 0000000000..126a9a69d3
--- /dev/null
+++ b/guix/transformations.scm
@@ -0,0 +1,610 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix transformations)
+ #:use-module (guix i18n)
+ #:use-module (guix store)
+ #:use-module (guix packages)
+ #:use-module (guix profiles)
+ #:use-module (guix diagnostics)
+ #:autoload (guix download) (download-to-store)
+ #:autoload (guix git-download) (git-reference? git-reference-url)
+ #:autoload (guix git) (git-checkout git-checkout? git-checkout-url)
+ #:use-module (guix utils)
+ #:use-module (guix memoization)
+ #:use-module (guix gexp)
+
+ ;; Use the procedure that destructures "NAME-VERSION" forms.
+ #:use-module ((guix build utils)
+ #:select ((package-name->name+version
+ . hyphen-package-name->name+version)))
+
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-37)
+ #:use-module (ice-9 match)
+ #:export (options->transformation
+ manifest-entry-with-transformations
+
+ show-transformation-options-help
+ %transformation-options))
+
+;;; Commentary:
+;;;
+;;; This module implements "package transformation options"---tools for
+;;; package graph rewriting. It contains the graph rewriting logic, but also
+;;; the tip of its user interface: command-line option handling.
+;;;
+;;; Code:
+
+(module-autoload! (current-module) '(gnu packages)
+ '(specification->package))
+
+(define (numeric-extension? file-name)
+ "Return true if FILE-NAME ends with digits."
+ (string-every char-set:hex-digit (file-extension file-name)))
+
+(define (tarball-base-name file-name)
+ "Return the \"base\" of FILE-NAME, removing '.tar.gz' or similar
+extensions."
+ ;; TODO: Factorize.
+ (cond ((not (file-extension file-name))
+ file-name)
+ ((numeric-extension? file-name)
+ file-name)
+ ((string=? (file-extension file-name) "tar")
+ (file-sans-extension file-name))
+ ((file-extension file-name)
+ =>
+ (match-lambda
+ ("scm" file-name)
+ (_ (tarball-base-name (file-sans-extension file-name)))))
+ (else
+ file-name)))
+
+
+;; Files to be downloaded.
+(define-record-type <downloaded-file>
+ (downloaded-file uri recursive?)
+ downloaded-file?
+ (uri downloaded-file-uri)
+ (recursive? downloaded-file-recursive?))
+
+(define download-to-store*
+ (store-lift download-to-store))
+
+(define-gexp-compiler (compile-downloaded-file (file <downloaded-file>)
+ system target)
+ "Download FILE and return the result as a store item."
+ (match file
+ (($ <downloaded-file> uri recursive?)
+ (download-to-store* uri #:recursive? recursive?))))
+
+(define* (package-with-source p uri #:optional version)
+ "Return a package based on P but with its source taken from URI. Extract
+the new package's version number from URI."
+ (let ((base (tarball-base-name (basename uri))))
+ (let-values (((_ version*)
+ (hyphen-package-name->name+version base)))
+ (package (inherit p)
+ (version (or version version*
+ (package-version p)))
+
+ ;; Use #:recursive? #t to allow for directories.
+ (source (downloaded-file uri #t))))))
+
+\f
+;;;
+;;; Transformations.
+;;;
+
+(define (transform-package-source sources)
+ "Return a transformation procedure that replaces package sources with the
+matching URIs given in SOURCES."
+ (define new-sources
+ (map (lambda (uri)
+ (match (string-index uri #\=)
+ (#f
+ ;; Determine the package name and version from URI.
+ (call-with-values
+ (lambda ()
+ (hyphen-package-name->name+version
+ (tarball-base-name (basename uri))))
+ (lambda (name version)
+ (list name version uri))))
+ (index
+ ;; What's before INDEX is a "PKG@VER" or "PKG" spec.
+ (call-with-values
+ (lambda ()
+ (package-name->name+version (string-take uri index)))
+ (lambda (name version)
+ (list name version
+ (string-drop uri (+ 1 index))))))))
+ sources))
+
+ (lambda (obj)
+ (let loop ((sources new-sources)
+ (result '()))
+ (match obj
+ ((? package? p)
+ (match (assoc-ref sources (package-name p))
+ ((version source)
+ (package-with-source p source version))
+ (#f
+ p)))
+ (_
+ obj)))))
+
+(define (evaluate-replacement-specs specs proc)
+ "Parse SPECS, a list of strings like \"guile=guile@2.1\" and return a list
+of package spec/procedure pairs as expected by 'package-input-rewriting/spec'.
+PROC is called with the package to be replaced and its replacement according
+to SPECS. Raise an error if an element of SPECS uses invalid syntax, or if a
+package it refers to could not be found."
+ (define not-equal
+ (char-set-complement (char-set #\=)))
+
+ (map (lambda (spec)
+ (match (string-tokenize spec not-equal)
+ ((spec new)
+ (cons spec
+ (let ((new (specification->package new)))
+ (lambda (old)
+ (proc old new)))))
+ (x
+ (leave (G_ "invalid replacement specification: ~s~%") spec))))
+ specs))
+
+(define (transform-package-inputs replacement-specs)
+ "Return a procedure that, when passed a package, replaces its direct
+dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
+strings like \"guile=guile@2.1\" meaning that, any dependency on a package
+called \"guile\" must be replaced with a dependency on a version 2.1 of
+\"guile\"."
+ (let* ((replacements (evaluate-replacement-specs replacement-specs
+ (lambda (old new)
+ new)))
+ (rewrite (package-input-rewriting/spec replacements)))
+ (lambda (obj)
+ (if (package? obj)
+ (rewrite obj)
+ obj))))
+
+(define (transform-package-inputs/graft replacement-specs)
+ "Return a procedure that, when passed a package, replaces its direct
+dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
+strings like \"gnutls=gnutls@3.5.4\" meaning that packages are built using the
+current 'gnutls' package, after which version 3.5.4 is grafted onto them."
+ (define (set-replacement old new)
+ (package (inherit old) (replacement new)))
+
+ (let* ((replacements (evaluate-replacement-specs replacement-specs
+ set-replacement))
+ (rewrite (package-input-rewriting/spec replacements)))
+ (lambda (obj)
+ (if (package? obj)
+ (rewrite obj)
+ obj))))
+
+(define %not-equal
+ (char-set-complement (char-set #\=)))
+
+(define (package-git-url package)
+ "Return the URL of the Git repository for package, or raise an error if
+the source of PACKAGE is not fetched from a Git repository."
+ (let ((source (package-source package)))
+ (cond ((and (origin? source)
+ (git-reference? (origin-uri source)))
+ (git-reference-url (origin-uri source)))
+ ((git-checkout? source)
+ (git-checkout-url source))
+ (else
+ (leave (G_ "the source of ~a is not a Git reference~%")
+ (package-full-name package))))))
+
+(define (evaluate-git-replacement-specs specs proc)
+ "Parse SPECS, a list of strings like \"guile=stable-2.2\", and return a list
+of package pairs, where (PROC PACKAGE URL BRANCH-OR-COMMIT) returns the
+replacement package. Raise an error if an element of SPECS uses invalid
+syntax, or if a package it refers to could not be found."
+ (map (lambda (spec)
+ (match (string-tokenize spec %not-equal)
+ ((spec branch-or-commit)
+ (define (replace old)
+ (let* ((source (package-source old))
+ (url (package-git-url old)))
+ (proc old url branch-or-commit)))
+
+ (cons spec replace))
+ (_
+ (leave (G_ "invalid replacement specification: ~s~%") spec))))
+ specs))
+
+(define (transform-package-source-branch replacement-specs)
+ "Return a procedure that, when passed a package, replaces its direct
+dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
+strings like \"guile-next=stable-3.0\" meaning that packages are built using
+'guile-next' from the latest commit on its 'stable-3.0' branch."
+ (define (replace old url branch)
+ (package
+ (inherit old)
+ (version (string-append "git." (string-map (match-lambda
+ (#\/ #\-)
+ (chr chr))
+ branch)))
+ (source (git-checkout (url url) (branch branch)
+ (recursive? #t)))))
+
+ (let* ((replacements (evaluate-git-replacement-specs replacement-specs
+ replace))
+ (rewrite (package-input-rewriting/spec replacements)))
+ (lambda (obj)
+ (if (package? obj)
+ (rewrite obj)
+ obj))))
+
+(define (transform-package-source-commit replacement-specs)
+ "Return a procedure that, when passed a package, replaces its direct
+dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
+strings like \"guile-next=cabba9e\" meaning that packages are built using
+'guile-next' from commit 'cabba9e'."
+ (define (replace old url commit)
+ (package
+ (inherit old)
+ (version (if (and (> (string-length commit) 1)
+ (string-prefix? "v" commit)
+ (char-set-contains? char-set:digit
+ (string-ref commit 1)))
+ (string-drop commit 1) ;looks like a tag like "v1.0"
+ (string-append "git."
+ (if (< (string-length commit) 7)
+ commit
+ (string-take commit 7)))))
+ (source (git-checkout (url url) (commit commit)
+ (recursive? #t)))))
+
+ (let* ((replacements (evaluate-git-replacement-specs replacement-specs
+ replace))
+ (rewrite (package-input-rewriting/spec replacements)))
+ (lambda (obj)
+ (if (package? obj)
+ (rewrite obj)
+ obj))))
+
+(define (transform-package-source-git-url replacement-specs)
+ "Return a procedure that, when passed a package, replaces its dependencies
+according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of strings like
+\"guile-json=https://gitthing.com/…\" meaning that packages are built using
+a checkout of the Git repository at the given URL."
+ (define replacements
+ (map (lambda (spec)
+ (match (string-tokenize spec %not-equal)
+ ((spec url)
+ (cons spec
+ (lambda (old)
+ (package
+ (inherit old)
+ (source (git-checkout (url url)
+ (recursive? #t)))))))
+ (_
+ (leave (G_ "~a: invalid Git URL replacement specification~%")
+ spec))))
+ replacement-specs))
+
+ (define rewrite
+ (package-input-rewriting/spec replacements))
+
+ (lambda (obj)
+ (if (package? obj)
+ (rewrite obj)
+ obj)))
+
+(define (package-dependents/spec top bottom)
+ "Return the list of dependents of BOTTOM, a spec string, that are also
+dependencies of TOP, a package."
+ (define-values (name version)
+ (package-name->name+version bottom))
+
+ (define dependent?
+ (mlambda (p)
+ (and (package? p)
+ (or (and (string=? name (package-name p))
+ (or (not version)
+ (version-prefix? version (package-version p))))
+ (match (bag-direct-inputs (package->bag p))
+ (((labels dependencies . _) ...)
+ (any dependent? dependencies)))))))
+
+ (filter dependent? (package-closure (list top))))
+
+(define (package-toolchain-rewriting p bottom toolchain)
+ "Return a procedure that, when passed a package that's either BOTTOM or one
+of its dependents up to P so, changes it so it is built with TOOLCHAIN.
+TOOLCHAIN must be an input list."
+ (define rewriting-property
+ (gensym " package-toolchain-rewriting"))
+
+ (match (package-dependents/spec p bottom)
+ (() ;P does not depend on BOTTOM
+ identity)
+ (set
+ ;; SET is the list of packages "between" P and BOTTOM (included) whose
+ ;; toolchain needs to be changed.
+ (package-mapping (lambda (p)
+ (if (or (assq rewriting-property
+ (package-properties p))
+ (not (memq p set)))
+ p
+ (let ((p (package-with-c-toolchain p toolchain)))
+ (package/inherit p
+ (properties `((,rewriting-property . #t)
+ ,@(package-properties p)))))))
+ (lambda (p)
+ (or (assq rewriting-property (package-properties p))
+ (not (memq p set))))
+ #:deep? #t))))
+
+(define (transform-package-toolchain replacement-specs)
+ "Return a procedure that, when passed a package, changes its toolchain or
+that of its dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is
+a list of strings like \"fftw=gcc-toolchain@10\" meaning that the package to
+the left of the equal sign must be built with the toolchain to the right of
+the equal sign."
+ (define split-on-commas
+ (cute string-tokenize <> (char-set-complement (char-set #\,))))
+
+ (define (specification->input spec)
+ (let ((package (specification->package spec)))
+ (list (package-name package) package)))
+
+ (define replacements
+ (map (lambda (spec)
+ (match (string-tokenize spec %not-equal)
+ ((spec (= split-on-commas toolchain))
+ (cons spec (map specification->input toolchain)))
+ (_
+ (leave (G_ "~a: invalid toolchain replacement specification~%")
+ spec))))
+ replacement-specs))
+
+ (lambda (obj)
+ (if (package? obj)
+ (or (any (match-lambda
+ ((bottom . toolchain)
+ ((package-toolchain-rewriting obj bottom toolchain) obj)))
+ replacements)
+ obj)
+ obj)))
+
+(define (transform-package-with-debug-info specs)
+ "Return a procedure that, when passed a package, set its 'replacement' field
+to the same package but with #:strip-binaries? #f in its 'arguments' field."
+ (define (non-stripped p)
+ (package
+ (inherit p)
+ (arguments
+ (substitute-keyword-arguments (package-arguments p)
+ ((#:strip-binaries? _ #f) #f)))))
+
+ (define (package-with-debug-info p)
+ (if (member "debug" (package-outputs p))
+ p
+ (let loop ((p p))
+ (match (package-replacement p)
+ (#f
+ (package
+ (inherit p)
+ (replacement (non-stripped p))))
+ (next
+ (package
+ (inherit p)
+ (replacement (loop next))))))))
+
+ (define rewrite
+ (package-input-rewriting/spec (map (lambda (spec)
+ (cons spec package-with-debug-info))
+ specs)))
+
+ (lambda (obj)
+ (if (package? obj)
+ (rewrite obj)
+ obj)))
+
+(define (transform-package-tests specs)
+ "Return a procedure that, when passed a package, sets #:tests? #f in its
+'arguments' field."
+ (define (package-without-tests p)
+ (package/inherit p
+ (arguments
+ (substitute-keyword-arguments (package-arguments p)
+ ((#:tests? _ #f) #f)))))
+
+ (define rewrite
+ (package-input-rewriting/spec (map (lambda (spec)
+ (cons spec package-without-tests))
+ specs)))
+
+ (lambda (obj)
+ (if (package? obj)
+ (rewrite obj)
+ obj)))
+
+(define %transformations
+ ;; Transformations that can be applied to things to build. The car is the
+ ;; key used in the option alist, and the cdr is the transformation
+ ;; procedure; it is called with two arguments: the store, and a list of
+ ;; things to build.
+ `((with-source . ,transform-package-source)
+ (with-input . ,transform-package-inputs)
+ (with-graft . ,transform-package-inputs/graft)
+ (with-branch . ,transform-package-source-branch)
+ (with-commit . ,transform-package-source-commit)
+ (with-git-url . ,transform-package-source-git-url)
+ (with-c-toolchain . ,transform-package-toolchain)
+ (with-debug-info . ,transform-package-with-debug-info)
+ (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))
+
+\f
+;;;
+;;; Command-line handling.
+;;;
+
+(define %transformation-options
+ ;; The command-line interface to the above transformations.
+ (let ((parser (lambda (symbol)
+ (lambda (opt name arg result . rest)
+ (apply values
+ (alist-cons symbol arg result)
+ rest)))))
+ (list (option '("with-source") #t #f
+ (parser 'with-source))
+ (option '("with-input") #t #f
+ (parser 'with-input))
+ (option '("with-graft") #t #f
+ (parser 'with-graft))
+ (option '("with-branch") #t #f
+ (parser 'with-branch))
+ (option '("with-commit") #t #f
+ (parser 'with-commit))
+ (option '("with-git-url") #t #f
+ (parser 'with-git-url))
+ (option '("with-c-toolchain") #t #f
+ (parser 'with-c-toolchain))
+ (option '("with-debug-info") #t #f
+ (parser 'with-debug-info))
+ (option '("without-tests") #t #f
+ (parser 'without-tests)))))
+
+(define (show-transformation-options-help)
+ (display (G_ "
+ --with-source=[PACKAGE=]SOURCE
+ use SOURCE when building the corresponding package"))
+ (display (G_ "
+ --with-input=PACKAGE=REPLACEMENT
+ replace dependency PACKAGE by REPLACEMENT"))
+ (display (G_ "
+ --with-graft=PACKAGE=REPLACEMENT
+ graft REPLACEMENT on packages that refer to PACKAGE"))
+ (display (G_ "
+ --with-branch=PACKAGE=BRANCH
+ build PACKAGE from the latest commit of BRANCH"))
+ (display (G_ "
+ --with-commit=PACKAGE=COMMIT
+ build PACKAGE from COMMIT"))
+ (display (G_ "
+ --with-git-url=PACKAGE=URL
+ build PACKAGE from the repository at URL"))
+ (display (G_ "
+ --with-c-toolchain=PACKAGE=TOOLCHAIN
+ build PACKAGE and its dependents with TOOLCHAIN"))
+ (display (G_ "
+ --with-debug-info=PACKAGE
+ build PACKAGE and preserve its debug info"))
+ (display (G_ "
+ --without-tests=PACKAGE
+ build PACKAGE without running its tests")))
+
+
+(define (options->transformation opts)
+ "Return a procedure that, when passed an object to build (package,
+derivation, etc.), applies the transformations specified by OPTS and returns
+the resulting objects. OPTS must be a list of symbol/string pairs such as:
+
+ ((with-branch . \"guile-gcrypt=master\")
+ (without-tests . \"libgcrypt\"))
+
+Each symbol names a transformation and the corresponding string is an argument
+to that transformation."
+ (define applicable
+ ;; List of applicable transformations as symbol/procedure pairs in the
+ ;; order in which they appear on the command line.
+ (filter-map (match-lambda
+ ((key . value)
+ (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.
+ (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 (obj)
+ (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 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/tests/scripts-build.scm b/tests/transformations.scm
similarity index 99%
rename from tests/scripts-build.scm
rename to tests/transformations.scm
index d56e02b452..07ed8b1234 100644
--- a/tests/scripts-build.scm
+++ b/tests/transformations.scm
@@ -16,7 +16,7 @@
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
-(define-module (test-scripts-build)
+(define-module (test-transformations)
#:use-module (guix tests)
#:use-module (guix store)
#:use-module ((guix gexp) #:select (lower-object))
@@ -25,7 +25,7 @@
#:use-module (guix git-download)
#:use-module (guix build-system)
#:use-module (guix build-system gnu)
- #:use-module (guix scripts build)
+ #:use-module (guix transformations)
#:use-module (guix ui)
#:use-module (guix utils)
#:use-module (guix git)
@@ -38,7 +38,7 @@
#:use-module (srfi srfi-64))
\f
-(test-begin "scripts-build")
+(test-begin "transformations")
(test-assert "options->transformation, no transformations"
(let ((p (dummy-package "foo"))
--
2.28.0
^ permalink raw reply related [flat|nested] 21+ messages in thread* [bug#44321] [PATCH 4/6] guix build: Move transformation options to (guix transformations).
2020-10-29 23:09 ` [bug#44321] [PATCH 4/6] guix build: Move transformation options to (guix transformations) Ludovic Courtès
@ 2020-10-30 23:03 ` Miguel Ángel Arruga Vivas
2020-10-31 10:04 ` Ludovic Courtès
0 siblings, 1 reply; 21+ messages in thread
From: Miguel Ángel Arruga Vivas @ 2020-10-30 23:03 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 44321
Hi Ludo,
Ludovic Courtès <ludo@gnu.org> writes:
> * guix/transformations.scm: New file.
The main comment regarding this patch is that file has to be added to
po/guix/POTFILES.in, or the translations will be lost.
I've seen that you've changed some code identifiers, here:
> - (else (tarball-base-name (file-sans-extension file-name)))))
> + (_ (tarball-base-name (file-sans-extension file-name)))))
And there:
> - (x
> + (_
And these changes seem sensible as the match parameter is unused.
Other than the first comment, the patch LGTM.
Happy hacking,
Miguel
^ permalink raw reply [flat|nested] 21+ messages in thread
* [bug#44321] [PATCH 4/6] guix build: Move transformation options to (guix transformations).
2020-10-30 23:03 ` Miguel Ángel Arruga Vivas
@ 2020-10-31 10:04 ` Ludovic Courtès
0 siblings, 0 replies; 21+ messages in thread
From: Ludovic Courtès @ 2020-10-31 10:04 UTC (permalink / raw)
To: Miguel Ángel Arruga Vivas; +Cc: 44321
Hi,
Miguel Ángel Arruga Vivas <rosen644835@gmail.com> skribis:
> Ludovic Courtès <ludo@gnu.org> writes:
>
>> * guix/transformations.scm: New file.
>
> The main comment regarding this patch is that file has to be added to
> po/guix/POTFILES.in, or the translations will be lost.
Indeed, I’ll add it to that file.
> I've seen that you've changed some code identifiers, here:
>> - (else (tarball-base-name (file-sans-extension file-name)))))
>> + (_ (tarball-base-name (file-sans-extension file-name)))))
>
> And there:
>> - (x
>> + (_
>
> And these changes seem sensible as the match parameter is unused.
Yeah.
Thanks!
Ludo’.
^ permalink raw reply [flat|nested] 21+ messages in thread
* [bug#44321] [PATCH 5/6] transformations: Raise '&formatted-message' exceptions instead of 'leave'.
2020-10-29 23:09 ` [bug#44321] [PATCH 1/6] guix build: 'package-with-source' no longer takes a 'store' parameter Ludovic Courtès
` (2 preceding siblings ...)
2020-10-29 23:09 ` [bug#44321] [PATCH 4/6] guix build: Move transformation options to (guix transformations) Ludovic Courtès
@ 2020-10-29 23:09 ` Ludovic Courtès
2020-10-30 10:59 ` zimoun
2020-10-29 23:10 ` [bug#44321] [PATCH 6/6] doc: Add "Defining Package Variants" section Ludovic Courtès
2020-10-30 23:27 ` [bug#44321] [PATCH 1/6] guix build: 'package-with-source' no longer takes a 'store' parameter Miguel Ángel Arruga Vivas
5 siblings, 1 reply; 21+ messages in thread
From: Ludovic Courtès @ 2020-10-29 23:09 UTC (permalink / raw)
To: 44321; +Cc: Ludovic Courtès
* guix/transformations.scm (evaluate-replacement-specs)
(package-git-url, evaluate-git-replacement-specs)
(transform-package-source-git-url)
(transform-package-toolchain): Use 'raise' and 'formatted-message'
instead of 'leave'.
---
guix/transformations.scm | 26 ++++++++++++++++++--------
1 file changed, 18 insertions(+), 8 deletions(-)
diff --git a/guix/transformations.scm b/guix/transformations.scm
index 126a9a69d3..30142dd059 100644
--- a/guix/transformations.scm
+++ b/guix/transformations.scm
@@ -38,6 +38,7 @@
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
#:use-module (srfi srfi-37)
#:use-module (ice-9 match)
#:export (options->transformation
@@ -169,7 +170,9 @@ package it refers to could not be found."
(lambda (old)
(proc old new)))))
(x
- (leave (G_ "invalid replacement specification: ~s~%") spec))))
+ (raise (formatted-message
+ (G_ "invalid replacement specification: ~s")
+ spec)))))
specs))
(define (transform-package-inputs replacement-specs)
@@ -216,8 +219,9 @@ the source of PACKAGE is not fetched from a Git repository."
((git-checkout? source)
(git-checkout-url source))
(else
- (leave (G_ "the source of ~a is not a Git reference~%")
- (package-full-name package))))))
+ (raise
+ (formatted-message (G_ "the source of ~a is not a Git reference")
+ (package-full-name package)))))))
(define (evaluate-git-replacement-specs specs proc)
"Parse SPECS, a list of strings like \"guile=stable-2.2\", and return a list
@@ -234,7 +238,9 @@ syntax, or if a package it refers to could not be found."
(cons spec replace))
(_
- (leave (G_ "invalid replacement specification: ~s~%") spec))))
+ (raise
+ (formatted-message (G_ "invalid replacement specification: ~s")
+ spec)))))
specs))
(define (transform-package-source-branch replacement-specs)
@@ -304,8 +310,10 @@ a checkout of the Git repository at the given URL."
(source (git-checkout (url url)
(recursive? #t)))))))
(_
- (leave (G_ "~a: invalid Git URL replacement specification~%")
- spec))))
+ (raise
+ (formatted-message
+ (G_ "~a: invalid Git URL replacement specification")
+ spec)))))
replacement-specs))
(define rewrite
@@ -380,8 +388,10 @@ the equal sign."
((spec (= split-on-commas toolchain))
(cons spec (map specification->input toolchain)))
(_
- (leave (G_ "~a: invalid toolchain replacement specification~%")
- spec))))
+ (raise
+ (formatted-message
+ (G_ "~a: invalid toolchain replacement specification")
+ spec)))))
replacement-specs))
(lambda (obj)
--
2.28.0
^ permalink raw reply related [flat|nested] 21+ messages in thread* [bug#44321] [PATCH 5/6] transformations: Raise '&formatted-message' exceptions instead of 'leave'.
2020-10-29 23:09 ` [bug#44321] [PATCH 5/6] transformations: Raise '&formatted-message' exceptions instead of 'leave' Ludovic Courtès
@ 2020-10-30 10:59 ` zimoun
2020-10-30 22:39 ` Miguel Ángel Arruga Vivas
0 siblings, 1 reply; 21+ messages in thread
From: zimoun @ 2020-10-30 10:59 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 44321
Hi,
On Fri, 30 Oct 2020 at 00:09, Ludovic Courtès <ludo@gnu.org> wrote:
> (transform-package-toolchain): Use 'raise' and 'formatted-message'
> instead of 'leave'.
Naive question: what is the difference? Other said why? And so why not
replaces ’leave’ here and there by ’raise’+’formatted-message’?
All the best,
simon
^ permalink raw reply [flat|nested] 21+ messages in thread
* [bug#44321] [PATCH 5/6] transformations: Raise '&formatted-message' exceptions instead of 'leave'.
2020-10-30 10:59 ` zimoun
@ 2020-10-30 22:39 ` Miguel Ángel Arruga Vivas
2020-10-31 10:06 ` Ludovic Courtès
0 siblings, 1 reply; 21+ messages in thread
From: Miguel Ángel Arruga Vivas @ 2020-10-30 22:39 UTC (permalink / raw)
To: zimoun; +Cc: Ludovic Courtès, 44321
[-- Attachment #1: Type: text/plain, Size: 810 bytes --]
Hi simon and Ludo,
zimoun <zimon.toutoune@gmail.com> writes:
> Hi,
>
> On Fri, 30 Oct 2020 at 00:09, Ludovic Courtès <ludo@gnu.org> wrote:
>
>> (transform-package-toolchain): Use 'raise' and 'formatted-message'
>> instead of 'leave'.
>
> Naive question: what is the difference? Other said why? And so why not
> replaces ’leave’ here and there by ’raise’+’formatted-message’?
Probably Ludo can explain better, but the main difference I see is that
leave (guix diagnostics) calls exit, so the client code now can handle
these errors and it isn't forced to exit.
The patch LGTM. Just one extra comment, this changes some format
strings, so we shouldn't forget to send the latest pot files to TP as
soon as we generate the branch for the release.
Happy hacking!
Miguel
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 658 bytes --]
^ permalink raw reply [flat|nested] 21+ messages in thread
* [bug#44321] [PATCH 5/6] transformations: Raise '&formatted-message' exceptions instead of 'leave'.
2020-10-30 22:39 ` Miguel Ángel Arruga Vivas
@ 2020-10-31 10:06 ` Ludovic Courtès
2020-10-31 22:18 ` bug#44321: " Ludovic Courtès
2020-11-02 12:25 ` [bug#44321] " zimoun
0 siblings, 2 replies; 21+ messages in thread
From: Ludovic Courtès @ 2020-10-31 10:06 UTC (permalink / raw)
To: Miguel Ángel Arruga Vivas; +Cc: 44321, zimoun
Hi,
Miguel Ángel Arruga Vivas <rosen644835@gmail.com> skribis:
> zimoun <zimon.toutoune@gmail.com> writes:
>
>> Hi,
>>
>> On Fri, 30 Oct 2020 at 00:09, Ludovic Courtès <ludo@gnu.org> wrote:
>>
>>> (transform-package-toolchain): Use 'raise' and 'formatted-message'
>>> instead of 'leave'.
>>
>> Naive question: what is the difference? Other said why? And so why not
>> replaces ’leave’ here and there by ’raise’+’formatted-message’?
>
> Probably Ludo can explain better, but the main difference I see is that
> leave (guix diagnostics) calls exit, so the client code now can handle
> these errors and it isn't forced to exit.
Exactly. In fact, ‘exit’ throws the 'quit exception, which one could
also catch, but it’s still nicer to throw &message or &formatted-message
within a module meant to be used as a library.
> The patch LGTM. Just one extra comment, this changes some format
> strings, so we shouldn't forget to send the latest pot files to TP as
> soon as we generate the branch for the release.
Yes.
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 21+ messages in thread
* bug#44321: [PATCH 5/6] transformations: Raise '&formatted-message' exceptions instead of 'leave'.
2020-10-31 10:06 ` Ludovic Courtès
@ 2020-10-31 22:18 ` Ludovic Courtès
2020-11-02 12:25 ` [bug#44321] " zimoun
1 sibling, 0 replies; 21+ messages in thread
From: Ludovic Courtès @ 2020-10-31 22:18 UTC (permalink / raw)
To: Miguel Ángel Arruga Vivas; +Cc: 44321-done, zimoun
Pushed as 95460da83b6ffd2bf3b96b3ab7cd302ab76be38a, thanks!
Ludo’.
^ permalink raw reply [flat|nested] 21+ messages in thread
* [bug#44321] [PATCH 5/6] transformations: Raise '&formatted-message' exceptions instead of 'leave'.
2020-10-31 10:06 ` Ludovic Courtès
2020-10-31 22:18 ` bug#44321: " Ludovic Courtès
@ 2020-11-02 12:25 ` zimoun
2020-11-02 15:48 ` Ludovic Courtès
1 sibling, 1 reply; 21+ messages in thread
From: zimoun @ 2020-11-02 12:25 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: Miguel Ángel Arruga Vivas, 44321
Hi,
Thanks for the explanation.
On Sat, 31 Oct 2020 at 11:06, Ludovic Courtès <ludo@gnu.org> wrote:
> >> Naive question: what is the difference? Other said why? And so why not
> >> replaces ’leave’ here and there by ’raise’+’formatted-message’?
> >
> > Probably Ludo can explain better, but the main difference I see is that
> > leave (guix diagnostics) calls exit, so the client code now can handle
> > these errors and it isn't forced to exit.
>
> Exactly. In fact, ‘exit’ throws the 'quit exception, which one could
> also catch, but it’s still nicer to throw &message or &formatted-message
> within a module meant to be used as a library.
And so why not replace the 'leave' appearing here and there in the
code by 'raise'+'formatted-message'?
Cheers,
simon
^ permalink raw reply [flat|nested] 21+ messages in thread
* [bug#44321] [PATCH 5/6] transformations: Raise '&formatted-message' exceptions instead of 'leave'.
2020-11-02 12:25 ` [bug#44321] " zimoun
@ 2020-11-02 15:48 ` Ludovic Courtès
0 siblings, 0 replies; 21+ messages in thread
From: Ludovic Courtès @ 2020-11-02 15:48 UTC (permalink / raw)
To: zimoun; +Cc: Miguel Ángel Arruga Vivas, 44321
zimoun <zimon.toutoune@gmail.com> skribis:
> On Sat, 31 Oct 2020 at 11:06, Ludovic Courtès <ludo@gnu.org> wrote:
>
>> >> Naive question: what is the difference? Other said why? And so why not
>> >> replaces ’leave’ here and there by ’raise’+’formatted-message’?
>> >
>> > Probably Ludo can explain better, but the main difference I see is that
>> > leave (guix diagnostics) calls exit, so the client code now can handle
>> > these errors and it isn't forced to exit.
>>
>> Exactly. In fact, ‘exit’ throws the 'quit exception, which one could
>> also catch, but it’s still nicer to throw &message or &formatted-message
>> within a module meant to be used as a library.
>
> And so why not replace the 'leave' appearing here and there in the
> code by 'raise'+'formatted-message'?
In (guix scripts …), using ‘leave’ is appropriate.
Ludo’.
^ permalink raw reply [flat|nested] 21+ messages in thread
* [bug#44321] [PATCH 6/6] doc: Add "Defining Package Variants" section.
2020-10-29 23:09 ` [bug#44321] [PATCH 1/6] guix build: 'package-with-source' no longer takes a 'store' parameter Ludovic Courtès
` (3 preceding siblings ...)
2020-10-29 23:09 ` [bug#44321] [PATCH 5/6] transformations: Raise '&formatted-message' exceptions instead of 'leave' Ludovic Courtès
@ 2020-10-29 23:10 ` Ludovic Courtès
2020-10-30 11:20 ` zimoun
2020-10-30 23:27 ` [bug#44321] [PATCH 1/6] guix build: 'package-with-source' no longer takes a 'store' parameter Miguel Ángel Arruga Vivas
5 siblings, 1 reply; 21+ messages in thread
From: Ludovic Courtès @ 2020-10-29 23:10 UTC (permalink / raw)
To: 44321; +Cc: Ludovic Courtès
* doc/guix.texi (Defining Packages): Move documentation of
'package-input-rewriting' & co. to...
(Defining Package Variants): ... here. New node. Also document
'inherit' and 'options->transformation'.
---
doc/guix.texi | 278 ++++++++++++++++++++++++++++++++++++--------------
1 file changed, 204 insertions(+), 74 deletions(-)
diff --git a/doc/guix.texi b/doc/guix.texi
index 22bddf10e3..831ee3f881 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -253,6 +253,7 @@ Programming Interface
* Package Modules:: Packages from the programmer's viewpoint.
* Defining Packages:: Defining new packages.
+* Defining Package Variants:: Customizing packages.
* Build Systems:: Specifying how packages are built.
* Build Phases:: Phases of the build process of a package.
* Build Utilities:: Helpers for your package definitions and more.
@@ -260,7 +261,7 @@ Programming Interface
* Derivations:: Low-level interface to package derivations.
* The Store Monad:: Purely functional interface to the store.
* G-Expressions:: Manipulating build expressions.
-* Invoking guix repl:: Programming Guix in Guile.
+* Invoking guix repl:: Programming Guix in Guile
Defining Packages
@@ -6204,6 +6205,7 @@ package definitions.
@menu
* Package Modules:: Packages from the programmer's viewpoint.
* Defining Packages:: Defining new packages.
+* Defining Package Variants:: Customizing packages.
* Build Systems:: Specifying how packages are built.
* Build Phases:: Phases of the build process of a package.
* Build Utilities:: Helpers for your package definitions and more.
@@ -6473,79 +6475,8 @@ and operating system, such as @code{"aarch64-linux-gnu"}
(@pxref{Specifying Target Triplets,,, autoconf, Autoconf}).
@end deffn
-@cindex package transformations
-@cindex input rewriting
-@cindex dependency tree rewriting
-Packages can be manipulated in arbitrary ways. An example of a useful
-transformation is @dfn{input rewriting}, whereby the dependency tree of
-a package is rewritten by replacing specific inputs by others:
-
-@deffn {Scheme Procedure} package-input-rewriting @var{replacements} @
- [@var{rewrite-name}] [#:deep? #t]
-Return a procedure that, when passed a package, replaces its direct and
-indirect dependencies, including implicit inputs when @var{deep?} is
-true, according to @var{replacements}. @var{replacements} is a list of
-package pairs; the first element of each pair is the package to replace,
-and the second one is the replacement.
-
-Optionally, @var{rewrite-name} is a one-argument procedure that takes
-the name of a package and returns its new name after rewrite.
-@end deffn
-
-@noindent
-Consider this example:
-
-@lisp
-(define libressl-instead-of-openssl
- ;; This is a procedure to replace OPENSSL by LIBRESSL,
- ;; recursively.
- (package-input-rewriting `((,openssl . ,libressl))))
-
-(define git-with-libressl
- (libressl-instead-of-openssl git))
-@end lisp
-
-@noindent
-Here we first define a rewriting procedure that replaces @var{openssl}
-with @var{libressl}. Then we use it to define a @dfn{variant} of the
-@var{git} package that uses @var{libressl} instead of @var{openssl}.
-This is exactly what the @option{--with-input} command-line option does
-(@pxref{Package Transformation Options, @option{--with-input}}).
-
-The following variant of @code{package-input-rewriting} can match packages to
-be replaced by name rather than by identity.
-
-@deffn {Scheme Procedure} package-input-rewriting/spec @var{replacements} [#:deep? #t]
-Return a procedure that, given a package, applies the given
-@var{replacements} to all the package graph, including implicit inputs
-unless @var{deep?} is false. @var{replacements} is a list of
-spec/procedures pair; each spec is a package specification such as
-@code{"gcc"} or @code{"guile@@2"}, and each procedure takes a matching
-package and returns a replacement for that package.
-@end deffn
-
-The example above could be rewritten this way:
-
-@lisp
-(define libressl-instead-of-openssl
- ;; Replace all the packages called "openssl" with LibreSSL.
- (package-input-rewriting/spec `(("openssl" . ,(const libressl)))))
-@end lisp
-
-The key difference here is that, this time, packages are matched by spec and
-not by identity. In other words, any package in the graph that is called
-@code{openssl} will be replaced.
-
-A more generic procedure to rewrite a package dependency graph is
-@code{package-mapping}: it supports arbitrary changes to nodes in the
-graph.
-
-@deffn {Scheme Procedure} package-mapping @var{proc} [@var{cut?}] [#:deep? #f]
-Return a procedure that, given a package, applies @var{proc} to all the packages
-depended on and returns the resulting package. The procedure stops recursion
-when @var{cut?} returns true for a given package. When @var{deep?} is true, @var{proc} is
-applied to implicit inputs as well.
-@end deffn
+Once you have package definitions, you can easily define @emph{variants}
+of those packages. @xref{Defining Package Variants}, for more on that.
@menu
* package Reference:: The package data type.
@@ -6903,6 +6834,200 @@ commit:
@end lisp
@end deftp
+@node Defining Package Variants
+@section Defining Package Variants
+
+@cindex customizing packages
+@cindex variants, of packages
+One of the nice things with Guix is that, given a package definition,
+you can easily @emph{derive} variants of that package---for a different
+upstream version, with different dependencies, different compilation
+options, and so on. Some of these custom packages can be defined
+straight from the command line (@pxref{Package Transformation Options}).
+This section describes how to define package variants in code. This can
+be useful in ``manifests'' (@pxref{profile-manifest,
+@option{--manifest}}) and in your own package collection
+(@pxref{Creating a Channel}), among others!
+
+@cindex inherit, for package definitions
+As discussed earlier, packages are first-class objects in the Scheme
+language. The @code{(guix packages)} module provides the @code{package}
+construct to define new package objects (@pxref{package Reference}).
+The easiest way to define a package variant is using the @code{inherit}
+keyword together with @code{package}. This allows you to inherit from a
+package definition while overriding the fields you want.
+
+For example, given the @code{hello} variable, which contains a
+definition for the current version of GNU@tie{}Hello, here's how you
+would define a variant for version 2.2 (released in 2006, it's
+vintage!):
+
+@lisp
+(use-modules (gnu packages base)) ;for 'hello'
+
+(define hello-2.2
+ (package
+ (inherit hello)
+ (version "2.2")
+ (source (origin
+ (method url-fetch)
+ (uri (string-append "mirror://gnu/hello/hello-" version
+ ".tar.gz"))
+ (sha256
+ (base32
+ "0lappv4slgb5spyqbh6yl5r013zv72yqg2pcl30mginf3wdqd8k9"))))))
+@end lisp
+
+The example above corresponds to what the @option{--with-source} package
+transformation option does. Essentially @code{hello-2.2} preserves all
+the fields of @code{hello}, except @code{version} and @code{source},
+which it overrides. Note that the original @code{hello} variable is
+still there, in the @code{(gnu packages base)} module, unchanged. When
+you define a custom package like this, you are really @emph{adding} a
+new package definition; the original one remains available.
+
+You can just as well define variants with a different set of
+dependencies than the original package. For example, the default
+@code{gdb} package depends on @code{guile}, but since that is an
+optional dependency, you can define a variant that removes that
+dependency like so:
+
+@lisp
+(use-modules (gnu packages gdb) ;for 'gdb'
+ (srfi srfi-1)) ;for 'alist-delete'
+
+(define gdb-sans-guile
+ (package
+ (inherit gdb)
+ (inputs (alist-delete "guile"
+ (package-inputs gdb)))))
+@end lisp
+
+@cindex package transformations
+These are pretty simple package variants. As a convenience, the
+@code{(guix transformations)} module provides a high-level interface
+that directly maps to package transformation options (@pxref{Package
+Transformation Options}):
+
+@deffn {Scheme Procedure} options->transformation @var{opts}
+Return a procedure that, when passed an object to build (package,
+derivation, etc.), applies the transformations specified by @var{opts} and returns
+the resulting objects. @var{opts} must be a list of symbol/string pairs such as:
+
+@example
+((with-branch . "guile-gcrypt=master")
+ (without-tests . "libgcrypt"))
+@end example
+
+Each symbol names a transformation and the corresponding string is an argument
+to that transformation.
+@end deffn
+
+For instance, a manifest equivalent to this command:
+
+@example
+guix build guix \
+ --with-branch=guile-gcrypt=master \
+ --with-debug-info=zlib
+@end example
+
+@noindent
+... would look like this:
+
+@lisp
+(use-modules (guix transformations))
+
+(define transform
+ ;; The package transformation procedure.
+ (options->transformation
+ '((with-branch . "guile-gcrypt=master")
+ (with-debug-info . "zlib"))))
+
+(packages->manifest
+ (list (transform (specification->package "guix"))))
+@end lisp
+
+@cindex input rewriting
+@cindex dependency graph rewriting
+The @code{options->transformation} procedure is convenient, but it's
+perhaps also not as flexible as you may like. How is it implemented?
+The astute reader probably noticed that most package transformation
+options go beyond the superficial changes shown in the first examples of
+this section: they involve @dfn{input rewriting}, whereby the dependency
+graph of a package is rewritten by replacing specific inputs by others.
+
+Dependency graph rewriting, for the purposes of swapping packages in the
+graph, is what the @code{package-input-rewriting} procedure in
+@code{(guix packages)} implements.
+
+@deffn {Scheme Procedure} package-input-rewriting @var{replacements} @
+ [@var{rewrite-name}] [#:deep? #t]
+Return a procedure that, when passed a package, replaces its direct and
+indirect dependencies, including implicit inputs when @var{deep?} is
+true, according to @var{replacements}. @var{replacements} is a list of
+package pairs; the first element of each pair is the package to replace,
+and the second one is the replacement.
+
+Optionally, @var{rewrite-name} is a one-argument procedure that takes
+the name of a package and returns its new name after rewrite.
+@end deffn
+
+@noindent
+Consider this example:
+
+@lisp
+(define libressl-instead-of-openssl
+ ;; This is a procedure to replace OPENSSL by LIBRESSL,
+ ;; recursively.
+ (package-input-rewriting `((,openssl . ,libressl))))
+
+(define git-with-libressl
+ (libressl-instead-of-openssl git))
+@end lisp
+
+@noindent
+Here we first define a rewriting procedure that replaces @var{openssl}
+with @var{libressl}. Then we use it to define a @dfn{variant} of the
+@var{git} package that uses @var{libressl} instead of @var{openssl}.
+This is exactly what the @option{--with-input} command-line option does
+(@pxref{Package Transformation Options, @option{--with-input}}).
+
+The following variant of @code{package-input-rewriting} can match packages to
+be replaced by name rather than by identity.
+
+@deffn {Scheme Procedure} package-input-rewriting/spec @var{replacements} [#:deep? #t]
+Return a procedure that, given a package, applies the given
+@var{replacements} to all the package graph, including implicit inputs
+unless @var{deep?} is false. @var{replacements} is a list of
+spec/procedures pair; each spec is a package specification such as
+@code{"gcc"} or @code{"guile@@2"}, and each procedure takes a matching
+package and returns a replacement for that package.
+@end deffn
+
+The example above could be rewritten this way:
+
+@lisp
+(define libressl-instead-of-openssl
+ ;; Replace all the packages called "openssl" with LibreSSL.
+ (package-input-rewriting/spec `(("openssl" . ,(const libressl)))))
+@end lisp
+
+The key difference here is that, this time, packages are matched by spec and
+not by identity. In other words, any package in the graph that is called
+@code{openssl} will be replaced.
+
+A more generic procedure to rewrite a package dependency graph is
+@code{package-mapping}: it supports arbitrary changes to nodes in the
+graph.
+
+@deffn {Scheme Procedure} package-mapping @var{proc} [@var{cut?}] [#:deep? #f]
+Return a procedure that, given a package, applies @var{proc} to all the packages
+depended on and returns the resulting package. The procedure stops recursion
+when @var{cut?} returns true for a given package. When @var{deep?} is true, @var{proc} is
+applied to implicit inputs as well.
+@end deffn
+
+
@node Build Systems
@section Build Systems
@@ -10155,6 +10280,11 @@ that does not respect a @code{#:tests? #f} setting. Therefore,
@end table
+Wondering how to achieve the same effect using Scheme code, for example
+in your manifest, or how to write your own package transformation?
+@xref{Defining Package Variants}, for an overview of the programming
+interfaces available.
+
@node Additional Build Options
@subsection Additional Build Options
--
2.28.0
^ permalink raw reply related [flat|nested] 21+ messages in thread* [bug#44321] [PATCH 6/6] doc: Add "Defining Package Variants" section.
2020-10-29 23:10 ` [bug#44321] [PATCH 6/6] doc: Add "Defining Package Variants" section Ludovic Courtès
@ 2020-10-30 11:20 ` zimoun
2020-10-31 10:14 ` Ludovic Courtès
0 siblings, 1 reply; 21+ messages in thread
From: zimoun @ 2020-10-30 11:20 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 44321
Hi,
On Fri, 30 Oct 2020 at 00:10, Ludovic Courtès <ludo@gnu.org> wrote:
> -* Invoking guix repl:: Programming Guix in Guile.
> +* Invoking guix repl:: Programming Guix in Guile
This change is already in commit 729d4ba025bc8556d00041f9af5b6609eeec9d80.
> +You can just as well define variants with a different set of
> +dependencies than the original package. For example, the default
> +@code{gdb} package depends on @code{guile}, but since that is an
> +optional dependency, you can define a variant that removes that
> +dependency like so:
> +
> +@lisp
> +(use-modules (gnu packages gdb) ;for 'gdb'
> + (srfi srfi-1)) ;for 'alist-delete'
> +
> +(define gdb-sans-guile
> + (package
> + (inherit gdb)
> + (inputs (alist-delete "guile"
> + (package-inputs gdb)))))
> +@end lisp
Does it make sense to add a sentence explaining that the “guile” is the
name provided by the string in the ’inputs’ list of the package ’gdb’,
namely:
--8<---------------cut here---------------start------------->8---
(inputs
`(("expat" ,expat)
("mpfr" ,mpfr)
("gmp" ,gmp)
("readline" ,readline)
("ncurses" ,ncurses)
("guile" ,guile-2.0)
("python-wrapper" ,python-wrapper)
("source-highlight" ,source-highlight)
;; Allow use of XML-formatted syscall information. This enables 'catch
;; syscall' and similar commands.
("libxml2" ,libxml2)
;; The Hurd needs -lshouldbeinlibc.
,@(if (hurd-target?) `(("hurd" ,hurd)) '())))
--8<---------------cut here---------------end--------------->8---
? Because it can be confusing. Especially when the ’rewriting’ works
on symbols instead.
> +@deffn {Scheme Procedure} options->transformation @var{opts}
> +Return a procedure that, when passed an object to build (package,
> +derivation, etc.), applies the transformations specified by @var{opts} and returns
> +the resulting objects. @var{opts} must be a list of symbol/string pairs such as:
> +
> +@example
> +((with-branch . "guile-gcrypt=master")
> + (without-tests . "libgcrypt"))
> +@end example
Is it on purpose that here you use ’without-tests’ and then…
> +Each symbol names a transformation and the corresponding string is an argument
> +to that transformation.
> +@end deffn
> +
> +For instance, a manifest equivalent to this command:
> +
> +@example
> +guix build guix \
> + --with-branch=guile-gcrypt=master \
> + --with-debug-info=zlib
> +@end example
> +
> +@noindent
> +... would look like this:
> +
> +@lisp
> +(use-modules (guix transformations))
> +
> +(define transform
> + ;; The package transformation procedure.
> + (options->transformation
> + '((with-branch . "guile-gcrypt=master")
> + (with-debug-info . "zlib"))))
> +
> +(packages->manifest
> + (list (transform (specification->package "guix"))))
> +@end lisp
…you use ’with-debug-info’ as example?
> +@lisp
> +(define libressl-instead-of-openssl
> + ;; Replace all the packages called "openssl" with LibreSSL.
> + (package-input-rewriting/spec `(("openssl" . ,(const libressl)))))
> +@end lisp
It is already in the manual but why this ’const’?
BTW, cool! Nice features! :-)
All the best,
simon
^ permalink raw reply [flat|nested] 21+ messages in thread* [bug#44321] [PATCH 6/6] doc: Add "Defining Package Variants" section.
2020-10-30 11:20 ` zimoun
@ 2020-10-31 10:14 ` Ludovic Courtès
0 siblings, 0 replies; 21+ messages in thread
From: Ludovic Courtès @ 2020-10-31 10:14 UTC (permalink / raw)
To: zimoun; +Cc: 44321
Hi,
zimoun <zimon.toutoune@gmail.com> skribis:
> On Fri, 30 Oct 2020 at 00:10, Ludovic Courtès <ludo@gnu.org> wrote:
>
>> -* Invoking guix repl:: Programming Guix in Guile.
>> +* Invoking guix repl:: Programming Guix in Guile
>
> This change is already in commit 729d4ba025bc8556d00041f9af5b6609eeec9d80.
OK, I’ll have to rebase and regenerate the menus maybe.
>> +You can just as well define variants with a different set of
>> +dependencies than the original package. For example, the default
>> +@code{gdb} package depends on @code{guile}, but since that is an
>> +optional dependency, you can define a variant that removes that
>> +dependency like so:
>> +
>> +@lisp
>> +(use-modules (gnu packages gdb) ;for 'gdb'
>> + (srfi srfi-1)) ;for 'alist-delete'
>> +
>> +(define gdb-sans-guile
>> + (package
>> + (inherit gdb)
>> + (inputs (alist-delete "guile"
>> + (package-inputs gdb)))))
>> +@end lisp
>
> Does it make sense to add a sentence explaining that the “guile” is the
> name provided by the string in the ’inputs’ list of the package ’gdb’,
Yeah, I’ll add a sentence like:
+The @code{alist-delete} call above removes the tuple from the
+@code{inputs} field that has @code{"guile"} as its first element
+(@pxref{SRFI-1 Association Lists,,, guile, GNU Guile Reference
+Manual}).
>> +@deffn {Scheme Procedure} options->transformation @var{opts}
>> +Return a procedure that, when passed an object to build (package,
>> +derivation, etc.), applies the transformations specified by @var{opts} and returns
>> +the resulting objects. @var{opts} must be a list of symbol/string pairs such as:
>> +
>> +@example
>> +((with-branch . "guile-gcrypt=master")
>> + (without-tests . "libgcrypt"))
>> +@end example
>
> Is it on purpose that here you use ’without-tests’ and then…
[...]
> …you use ’with-debug-info’ as example?
Yeah, the two examples are independent of one another so I guess it’s
fine to have some diversity, no?
>> +@lisp
>> +(define libressl-instead-of-openssl
>> + ;; Replace all the packages called "openssl" with LibreSSL.
>> + (package-input-rewriting/spec `(("openssl" . ,(const libressl)))))
>> +@end lisp
>
> It is already in the manual but why this ’const’?
Because ‘package-input-rewriting/spec’ takes a list of spec/procedure
pairs.
Thanks!
Ludo’.
^ permalink raw reply [flat|nested] 21+ messages in thread
* [bug#44321] [PATCH 1/6] guix build: 'package-with-source' no longer takes a 'store' parameter.
2020-10-29 23:09 ` [bug#44321] [PATCH 1/6] guix build: 'package-with-source' no longer takes a 'store' parameter Ludovic Courtès
` (4 preceding siblings ...)
2020-10-29 23:10 ` [bug#44321] [PATCH 6/6] doc: Add "Defining Package Variants" section Ludovic Courtès
@ 2020-10-30 23:27 ` Miguel Ángel Arruga Vivas
2020-10-31 10:17 ` Ludovic Courtès
5 siblings, 1 reply; 21+ messages in thread
From: Miguel Ángel Arruga Vivas @ 2020-10-30 23:27 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 44321
[-- Attachment #1: Type: text/plain, Size: 3190 bytes --]
Hi Ludo,
I've had to re-read some parts of the manual and the code of (guix
store) a bit to completely understand this one, so thank you for the
practical lesson too. :-)
To be sure that I understood it: the main difference is that now
package-with-source _stages_ (wink) the source download up to the gexp
compilation, isn't it? If that's the case, this LGTM and my quick
tests.
Happy hacking,
Miguel
Ludovic Courtès <ludo@gnu.org> writes:
> * guix/scripts/build.scm (<downloaded-file>): New record type.
> (download-to-store*): New variable.
> (compile-downloaded-file): New procedure.
> (package-with-source): Remove 'store' parameter. Use 'downloaded-file'
> instead of 'download-to-store'.
> (transform-package-source): Adjust accordingly.
> ---
> guix/scripts/build.scm | 26 ++++++++++++++++++++++----
> 1 file changed, 22 insertions(+), 4 deletions(-)
>
> diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
> index f4a8af035b..831ac8f798 100644
> --- a/guix/scripts/build.scm
> +++ b/guix/scripts/build.scm
> @@ -45,6 +45,7 @@
> #:use-module (ice-9 match)
> #:use-module (ice-9 vlist)
> #:use-module (srfi srfi-1)
> + #:use-module (srfi srfi-9)
> #:use-module (srfi srfi-11)
> #:use-module (srfi srfi-26)
> #:use-module (srfi srfi-34)
> @@ -172,7 +173,25 @@ extensions."
> (else
> file-name)))
>
> -(define* (package-with-source store p uri #:optional version)
> +
> +;; Files to be downloaded.
> +(define-record-type <downloaded-file>
> + (downloaded-file uri recursive?)
> + downloaded-file?
> + (uri downloaded-file-uri)
> + (recursive? downloaded-file-recursive?))
> +
> +(define download-to-store*
> + (store-lift download-to-store))
> +
> +(define-gexp-compiler (compile-downloaded-file (file <downloaded-file>)
> + system target)
> + "Download FILE and return the result as a store item."
> + (match file
> + (($ <downloaded-file> uri recursive?)
> + (download-to-store* uri #:recursive? recursive?))))
> +
> +(define* (package-with-source p uri #:optional version)
> "Return a package based on P but with its source taken from URI. Extract
> the new package's version number from URI."
> (let ((base (tarball-base-name (basename uri))))
> @@ -183,8 +202,7 @@ the new package's version number from URI."
> (package-version p)))
>
> ;; Use #:recursive? #t to allow for directories.
> - (source (download-to-store store uri
> - #:recursive? #t))
> + (source (downloaded-file uri #t))
>
> ;; Override the replacement, otherwise '--with-source' would
> ;; have no effect.
> @@ -226,7 +244,7 @@ matching URIs given in SOURCES."
> ((? package? p)
> (match (assoc-ref sources (package-name p))
> ((version source)
> - (package-with-source store p source version))
> + (package-with-source p source version))
> (#f
> p)))
> (_
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 658 bytes --]
^ permalink raw reply [flat|nested] 21+ messages in thread* [bug#44321] [PATCH 1/6] guix build: 'package-with-source' no longer takes a 'store' parameter.
2020-10-30 23:27 ` [bug#44321] [PATCH 1/6] guix build: 'package-with-source' no longer takes a 'store' parameter Miguel Ángel Arruga Vivas
@ 2020-10-31 10:17 ` Ludovic Courtès
0 siblings, 0 replies; 21+ messages in thread
From: Ludovic Courtès @ 2020-10-31 10:17 UTC (permalink / raw)
To: Miguel Ángel Arruga Vivas; +Cc: 44321
Miguel Ángel Arruga Vivas <rosen644835@gmail.com> skribis:
> I've had to re-read some parts of the manual and the code of (guix
> store) a bit to completely understand this one, so thank you for the
> practical lesson too. :-)
Heheh. :-)
> To be sure that I understood it: the main difference is that now
> package-with-source _stages_ (wink) the source download up to the gexp
> compilation, isn't it? If that's the case, this LGTM and my quick
> tests.
Yes, exactly. Now ‘package-with-source’ inserts an “inert”
<downloaded-file> record as the source of the package. The file is
actually downloaded when that <downloaded-file> object is “lowered”,
which happens when the package itself is lowered to a derivation.
Thanks for the review!
Ludo’.
^ permalink raw reply [flat|nested] 21+ messages in thread