Commit | Line | Data |
---|---|---|
f68b3ba1 | 1 | ;;; GNU Guix --- Functional package management for GNU |
9ab817b2 | 2 | ;;; Copyright © 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> |
f68b3ba1 LC |
3 | ;;; |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
7 | ;;; under the terms of the GNU General Public License as published by | |
8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
9 | ;;; your option) any later version. | |
10 | ;;; | |
11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;;; GNU General Public License for more details. | |
15 | ;;; | |
16 | ;;; You should have received a copy of the GNU General Public License | |
17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
18 | ||
19 | (define-module (guix transformations) | |
20 | #:use-module (guix i18n) | |
21 | #:use-module (guix store) | |
22 | #:use-module (guix packages) | |
23 | #:use-module (guix profiles) | |
24 | #:use-module (guix diagnostics) | |
25 | #:autoload (guix download) (download-to-store) | |
26 | #:autoload (guix git-download) (git-reference? git-reference-url) | |
27 | #:autoload (guix git) (git-checkout git-checkout? git-checkout-url) | |
9ab817b2 LC |
28 | #:autoload (guix upstream) (package-latest-release* |
29 | upstream-source-version | |
30 | upstream-source-signature-urls) | |
f68b3ba1 LC |
31 | #:use-module (guix utils) |
32 | #:use-module (guix memoization) | |
33 | #:use-module (guix gexp) | |
34 | ||
35 | ;; Use the procedure that destructures "NAME-VERSION" forms. | |
36 | #:use-module ((guix build utils) | |
37 | #:select ((package-name->name+version | |
38 | . hyphen-package-name->name+version))) | |
39 | ||
40 | #:use-module (srfi srfi-1) | |
41 | #:use-module (srfi srfi-9) | |
42 | #:use-module (srfi srfi-11) | |
43 | #:use-module (srfi srfi-26) | |
31726f32 | 44 | #:use-module (srfi srfi-34) |
f68b3ba1 LC |
45 | #:use-module (srfi srfi-37) |
46 | #:use-module (ice-9 match) | |
e38d90d4 | 47 | #:use-module (ice-9 vlist) |
f68b3ba1 LC |
48 | #:export (options->transformation |
49 | manifest-entry-with-transformations | |
50 | ||
51 | show-transformation-options-help | |
52 | %transformation-options)) | |
53 | ||
54 | ;;; Commentary: | |
55 | ;;; | |
56 | ;;; This module implements "package transformation options"---tools for | |
57 | ;;; package graph rewriting. It contains the graph rewriting logic, but also | |
58 | ;;; the tip of its user interface: command-line option handling. | |
59 | ;;; | |
60 | ;;; Code: | |
61 | ||
62 | (module-autoload! (current-module) '(gnu packages) | |
63 | '(specification->package)) | |
64 | ||
65 | (define (numeric-extension? file-name) | |
66 | "Return true if FILE-NAME ends with digits." | |
67 | (string-every char-set:hex-digit (file-extension file-name))) | |
68 | ||
69 | (define (tarball-base-name file-name) | |
70 | "Return the \"base\" of FILE-NAME, removing '.tar.gz' or similar | |
71 | extensions." | |
72 | ;; TODO: Factorize. | |
73 | (cond ((not (file-extension file-name)) | |
74 | file-name) | |
75 | ((numeric-extension? file-name) | |
76 | file-name) | |
77 | ((string=? (file-extension file-name) "tar") | |
78 | (file-sans-extension file-name)) | |
79 | ((file-extension file-name) | |
80 | => | |
81 | (match-lambda | |
82 | ("scm" file-name) | |
83 | (_ (tarball-base-name (file-sans-extension file-name))))) | |
84 | (else | |
85 | file-name))) | |
86 | ||
87 | ||
88 | ;; Files to be downloaded. | |
89 | (define-record-type <downloaded-file> | |
90 | (downloaded-file uri recursive?) | |
91 | downloaded-file? | |
92 | (uri downloaded-file-uri) | |
93 | (recursive? downloaded-file-recursive?)) | |
94 | ||
95 | (define download-to-store* | |
96 | (store-lift download-to-store)) | |
97 | ||
98 | (define-gexp-compiler (compile-downloaded-file (file <downloaded-file>) | |
99 | system target) | |
100 | "Download FILE and return the result as a store item." | |
101 | (match file | |
102 | (($ <downloaded-file> uri recursive?) | |
103 | (download-to-store* uri #:recursive? recursive?)))) | |
104 | ||
105 | (define* (package-with-source p uri #:optional version) | |
106 | "Return a package based on P but with its source taken from URI. Extract | |
107 | the new package's version number from URI." | |
108 | (let ((base (tarball-base-name (basename uri)))) | |
109 | (let-values (((_ version*) | |
110 | (hyphen-package-name->name+version base))) | |
111 | (package (inherit p) | |
112 | (version (or version version* | |
113 | (package-version p))) | |
114 | ||
115 | ;; Use #:recursive? #t to allow for directories. | |
116 | (source (downloaded-file uri #t)))))) | |
117 | ||
118 | \f | |
119 | ;;; | |
120 | ;;; Transformations. | |
121 | ;;; | |
122 | ||
123 | (define (transform-package-source sources) | |
124 | "Return a transformation procedure that replaces package sources with the | |
125 | matching URIs given in SOURCES." | |
126 | (define new-sources | |
127 | (map (lambda (uri) | |
128 | (match (string-index uri #\=) | |
129 | (#f | |
130 | ;; Determine the package name and version from URI. | |
131 | (call-with-values | |
132 | (lambda () | |
133 | (hyphen-package-name->name+version | |
134 | (tarball-base-name (basename uri)))) | |
135 | (lambda (name version) | |
136 | (list name version uri)))) | |
137 | (index | |
138 | ;; What's before INDEX is a "PKG@VER" or "PKG" spec. | |
139 | (call-with-values | |
140 | (lambda () | |
141 | (package-name->name+version (string-take uri index))) | |
142 | (lambda (name version) | |
143 | (list name version | |
144 | (string-drop uri (+ 1 index)))))))) | |
145 | sources)) | |
146 | ||
147 | (lambda (obj) | |
148 | (let loop ((sources new-sources) | |
149 | (result '())) | |
150 | (match obj | |
151 | ((? package? p) | |
152 | (match (assoc-ref sources (package-name p)) | |
153 | ((version source) | |
154 | (package-with-source p source version)) | |
155 | (#f | |
156 | p))) | |
157 | (_ | |
158 | obj))))) | |
159 | ||
160 | (define (evaluate-replacement-specs specs proc) | |
161 | "Parse SPECS, a list of strings like \"guile=guile@2.1\" and return a list | |
162 | of package spec/procedure pairs as expected by 'package-input-rewriting/spec'. | |
163 | PROC is called with the package to be replaced and its replacement according | |
164 | to SPECS. Raise an error if an element of SPECS uses invalid syntax, or if a | |
165 | package it refers to could not be found." | |
166 | (define not-equal | |
167 | (char-set-complement (char-set #\=))) | |
168 | ||
169 | (map (lambda (spec) | |
170 | (match (string-tokenize spec not-equal) | |
171 | ((spec new) | |
172 | (cons spec | |
173 | (let ((new (specification->package new))) | |
174 | (lambda (old) | |
175 | (proc old new))))) | |
176 | (x | |
31726f32 LC |
177 | (raise (formatted-message |
178 | (G_ "invalid replacement specification: ~s") | |
179 | spec))))) | |
f68b3ba1 LC |
180 | specs)) |
181 | ||
182 | (define (transform-package-inputs replacement-specs) | |
183 | "Return a procedure that, when passed a package, replaces its direct | |
184 | dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of | |
185 | strings like \"guile=guile@2.1\" meaning that, any dependency on a package | |
186 | called \"guile\" must be replaced with a dependency on a version 2.1 of | |
187 | \"guile\"." | |
188 | (let* ((replacements (evaluate-replacement-specs replacement-specs | |
189 | (lambda (old new) | |
190 | new))) | |
191 | (rewrite (package-input-rewriting/spec replacements))) | |
192 | (lambda (obj) | |
193 | (if (package? obj) | |
194 | (rewrite obj) | |
195 | obj)))) | |
196 | ||
197 | (define (transform-package-inputs/graft replacement-specs) | |
198 | "Return a procedure that, when passed a package, replaces its direct | |
199 | dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of | |
200 | strings like \"gnutls=gnutls@3.5.4\" meaning that packages are built using the | |
201 | current 'gnutls' package, after which version 3.5.4 is grafted onto them." | |
202 | (define (set-replacement old new) | |
203 | (package (inherit old) (replacement new))) | |
204 | ||
205 | (let* ((replacements (evaluate-replacement-specs replacement-specs | |
206 | set-replacement)) | |
207 | (rewrite (package-input-rewriting/spec replacements))) | |
208 | (lambda (obj) | |
209 | (if (package? obj) | |
210 | (rewrite obj) | |
211 | obj)))) | |
212 | ||
213 | (define %not-equal | |
214 | (char-set-complement (char-set #\=))) | |
215 | ||
216 | (define (package-git-url package) | |
217 | "Return the URL of the Git repository for package, or raise an error if | |
218 | the source of PACKAGE is not fetched from a Git repository." | |
219 | (let ((source (package-source package))) | |
220 | (cond ((and (origin? source) | |
221 | (git-reference? (origin-uri source))) | |
222 | (git-reference-url (origin-uri source))) | |
223 | ((git-checkout? source) | |
224 | (git-checkout-url source)) | |
225 | (else | |
31726f32 LC |
226 | (raise |
227 | (formatted-message (G_ "the source of ~a is not a Git reference") | |
228 | (package-full-name package))))))) | |
f68b3ba1 LC |
229 | |
230 | (define (evaluate-git-replacement-specs specs proc) | |
231 | "Parse SPECS, a list of strings like \"guile=stable-2.2\", and return a list | |
232 | of package pairs, where (PROC PACKAGE URL BRANCH-OR-COMMIT) returns the | |
233 | replacement package. Raise an error if an element of SPECS uses invalid | |
234 | syntax, or if a package it refers to could not be found." | |
235 | (map (lambda (spec) | |
236 | (match (string-tokenize spec %not-equal) | |
237 | ((spec branch-or-commit) | |
238 | (define (replace old) | |
239 | (let* ((source (package-source old)) | |
240 | (url (package-git-url old))) | |
241 | (proc old url branch-or-commit))) | |
242 | ||
243 | (cons spec replace)) | |
244 | (_ | |
31726f32 LC |
245 | (raise |
246 | (formatted-message (G_ "invalid replacement specification: ~s") | |
247 | spec))))) | |
f68b3ba1 LC |
248 | specs)) |
249 | ||
250 | (define (transform-package-source-branch replacement-specs) | |
251 | "Return a procedure that, when passed a package, replaces its direct | |
252 | dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of | |
253 | strings like \"guile-next=stable-3.0\" meaning that packages are built using | |
254 | 'guile-next' from the latest commit on its 'stable-3.0' branch." | |
255 | (define (replace old url branch) | |
256 | (package | |
257 | (inherit old) | |
258 | (version (string-append "git." (string-map (match-lambda | |
259 | (#\/ #\-) | |
260 | (chr chr)) | |
261 | branch))) | |
262 | (source (git-checkout (url url) (branch branch) | |
263 | (recursive? #t))))) | |
264 | ||
265 | (let* ((replacements (evaluate-git-replacement-specs replacement-specs | |
266 | replace)) | |
267 | (rewrite (package-input-rewriting/spec replacements))) | |
268 | (lambda (obj) | |
269 | (if (package? obj) | |
270 | (rewrite obj) | |
271 | obj)))) | |
272 | ||
273 | (define (transform-package-source-commit replacement-specs) | |
274 | "Return a procedure that, when passed a package, replaces its direct | |
275 | dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of | |
276 | strings like \"guile-next=cabba9e\" meaning that packages are built using | |
277 | 'guile-next' from commit 'cabba9e'." | |
278 | (define (replace old url commit) | |
279 | (package | |
280 | (inherit old) | |
281 | (version (if (and (> (string-length commit) 1) | |
282 | (string-prefix? "v" commit) | |
283 | (char-set-contains? char-set:digit | |
284 | (string-ref commit 1))) | |
285 | (string-drop commit 1) ;looks like a tag like "v1.0" | |
286 | (string-append "git." | |
287 | (if (< (string-length commit) 7) | |
288 | commit | |
289 | (string-take commit 7))))) | |
290 | (source (git-checkout (url url) (commit commit) | |
291 | (recursive? #t))))) | |
292 | ||
293 | (let* ((replacements (evaluate-git-replacement-specs replacement-specs | |
294 | replace)) | |
295 | (rewrite (package-input-rewriting/spec replacements))) | |
296 | (lambda (obj) | |
297 | (if (package? obj) | |
298 | (rewrite obj) | |
299 | obj)))) | |
300 | ||
301 | (define (transform-package-source-git-url replacement-specs) | |
302 | "Return a procedure that, when passed a package, replaces its dependencies | |
303 | according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of strings like | |
304 | \"guile-json=https://gitthing.com/…\" meaning that packages are built using | |
305 | a checkout of the Git repository at the given URL." | |
306 | (define replacements | |
307 | (map (lambda (spec) | |
308 | (match (string-tokenize spec %not-equal) | |
309 | ((spec url) | |
310 | (cons spec | |
311 | (lambda (old) | |
312 | (package | |
313 | (inherit old) | |
314 | (source (git-checkout (url url) | |
315 | (recursive? #t))))))) | |
316 | (_ | |
31726f32 LC |
317 | (raise |
318 | (formatted-message | |
319 | (G_ "~a: invalid Git URL replacement specification") | |
320 | spec))))) | |
f68b3ba1 LC |
321 | replacement-specs)) |
322 | ||
323 | (define rewrite | |
324 | (package-input-rewriting/spec replacements)) | |
325 | ||
326 | (lambda (obj) | |
327 | (if (package? obj) | |
328 | (rewrite obj) | |
329 | obj))) | |
330 | ||
331 | (define (package-dependents/spec top bottom) | |
332 | "Return the list of dependents of BOTTOM, a spec string, that are also | |
333 | dependencies of TOP, a package." | |
334 | (define-values (name version) | |
335 | (package-name->name+version bottom)) | |
336 | ||
337 | (define dependent? | |
338 | (mlambda (p) | |
339 | (and (package? p) | |
340 | (or (and (string=? name (package-name p)) | |
341 | (or (not version) | |
342 | (version-prefix? version (package-version p)))) | |
343 | (match (bag-direct-inputs (package->bag p)) | |
344 | (((labels dependencies . _) ...) | |
345 | (any dependent? dependencies))))))) | |
346 | ||
347 | (filter dependent? (package-closure (list top)))) | |
348 | ||
349 | (define (package-toolchain-rewriting p bottom toolchain) | |
350 | "Return a procedure that, when passed a package that's either BOTTOM or one | |
351 | of its dependents up to P so, changes it so it is built with TOOLCHAIN. | |
352 | TOOLCHAIN must be an input list." | |
353 | (define rewriting-property | |
354 | (gensym " package-toolchain-rewriting")) | |
355 | ||
356 | (match (package-dependents/spec p bottom) | |
357 | (() ;P does not depend on BOTTOM | |
358 | identity) | |
359 | (set | |
360 | ;; SET is the list of packages "between" P and BOTTOM (included) whose | |
361 | ;; toolchain needs to be changed. | |
362 | (package-mapping (lambda (p) | |
363 | (if (or (assq rewriting-property | |
364 | (package-properties p)) | |
365 | (not (memq p set))) | |
366 | p | |
367 | (let ((p (package-with-c-toolchain p toolchain))) | |
368 | (package/inherit p | |
369 | (properties `((,rewriting-property . #t) | |
370 | ,@(package-properties p))))))) | |
371 | (lambda (p) | |
372 | (or (assq rewriting-property (package-properties p)) | |
373 | (not (memq p set)))) | |
374 | #:deep? #t)))) | |
375 | ||
376 | (define (transform-package-toolchain replacement-specs) | |
377 | "Return a procedure that, when passed a package, changes its toolchain or | |
378 | that of its dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is | |
379 | a list of strings like \"fftw=gcc-toolchain@10\" meaning that the package to | |
380 | the left of the equal sign must be built with the toolchain to the right of | |
381 | the equal sign." | |
382 | (define split-on-commas | |
383 | (cute string-tokenize <> (char-set-complement (char-set #\,)))) | |
384 | ||
385 | (define (specification->input spec) | |
386 | (let ((package (specification->package spec))) | |
387 | (list (package-name package) package))) | |
388 | ||
389 | (define replacements | |
390 | (map (lambda (spec) | |
391 | (match (string-tokenize spec %not-equal) | |
392 | ((spec (= split-on-commas toolchain)) | |
393 | (cons spec (map specification->input toolchain))) | |
394 | (_ | |
31726f32 LC |
395 | (raise |
396 | (formatted-message | |
397 | (G_ "~a: invalid toolchain replacement specification") | |
398 | spec))))) | |
f68b3ba1 LC |
399 | replacement-specs)) |
400 | ||
401 | (lambda (obj) | |
402 | (if (package? obj) | |
403 | (or (any (match-lambda | |
404 | ((bottom . toolchain) | |
405 | ((package-toolchain-rewriting obj bottom toolchain) obj))) | |
406 | replacements) | |
407 | obj) | |
408 | obj))) | |
409 | ||
410 | (define (transform-package-with-debug-info specs) | |
411 | "Return a procedure that, when passed a package, set its 'replacement' field | |
412 | to the same package but with #:strip-binaries? #f in its 'arguments' field." | |
413 | (define (non-stripped p) | |
414 | (package | |
415 | (inherit p) | |
416 | (arguments | |
417 | (substitute-keyword-arguments (package-arguments p) | |
418 | ((#:strip-binaries? _ #f) #f))))) | |
419 | ||
420 | (define (package-with-debug-info p) | |
421 | (if (member "debug" (package-outputs p)) | |
422 | p | |
423 | (let loop ((p p)) | |
424 | (match (package-replacement p) | |
425 | (#f | |
426 | (package | |
427 | (inherit p) | |
428 | (replacement (non-stripped p)))) | |
429 | (next | |
430 | (package | |
431 | (inherit p) | |
432 | (replacement (loop next)))))))) | |
433 | ||
434 | (define rewrite | |
435 | (package-input-rewriting/spec (map (lambda (spec) | |
436 | (cons spec package-with-debug-info)) | |
437 | specs))) | |
438 | ||
439 | (lambda (obj) | |
440 | (if (package? obj) | |
441 | (rewrite obj) | |
442 | obj))) | |
443 | ||
444 | (define (transform-package-tests specs) | |
445 | "Return a procedure that, when passed a package, sets #:tests? #f in its | |
446 | 'arguments' field." | |
447 | (define (package-without-tests p) | |
448 | (package/inherit p | |
449 | (arguments | |
450 | (substitute-keyword-arguments (package-arguments p) | |
451 | ((#:tests? _ #f) #f))))) | |
452 | ||
453 | (define rewrite | |
454 | (package-input-rewriting/spec (map (lambda (spec) | |
455 | (cons spec package-without-tests)) | |
456 | specs))) | |
457 | ||
458 | (lambda (obj) | |
459 | (if (package? obj) | |
460 | (rewrite obj) | |
461 | obj))) | |
462 | ||
e38d90d4 LC |
463 | (define (transform-package-patches specs) |
464 | "Return a procedure that, when passed a package, returns a package with | |
465 | additional patches." | |
466 | (define (package-with-extra-patches p patches) | |
467 | (if (origin? (package-source p)) | |
468 | (package/inherit p | |
469 | (source (origin | |
470 | (inherit (package-source p)) | |
471 | (patches (append (map (lambda (file) | |
472 | (local-file file)) | |
473 | patches) | |
474 | (origin-patches (package-source p))))))) | |
475 | p)) | |
476 | ||
477 | (define (coalesce-alist alist) | |
478 | ;; Coalesce multiple occurrences of the same key in ALIST. | |
479 | (let loop ((alist alist) | |
480 | (keys '()) | |
481 | (mapping vlist-null)) | |
482 | (match alist | |
483 | (() | |
484 | (map (lambda (key) | |
485 | (cons key (vhash-fold* cons '() key mapping))) | |
486 | (delete-duplicates (reverse keys)))) | |
487 | (((key . value) . rest) | |
488 | (loop rest | |
489 | (cons key keys) | |
490 | (vhash-cons key value mapping)))))) | |
491 | ||
492 | (define patches | |
493 | ;; Spec/patch alist. | |
494 | (coalesce-alist | |
495 | (map (lambda (spec) | |
496 | (match (string-tokenize spec %not-equal) | |
497 | ((spec patch) | |
498 | (cons spec (canonicalize-path patch))) | |
499 | (_ | |
500 | (raise (formatted-message | |
501 | (G_ "~a: invalid package patch specification") | |
502 | spec))))) | |
503 | specs))) | |
504 | ||
505 | (define rewrite | |
506 | (package-input-rewriting/spec | |
507 | (map (match-lambda | |
508 | ((spec . patches) | |
509 | (cons spec (cut package-with-extra-patches <> patches)))) | |
510 | patches))) | |
511 | ||
512 | (lambda (obj) | |
513 | (if (package? obj) | |
514 | (rewrite obj) | |
515 | obj))) | |
516 | ||
9ab817b2 LC |
517 | (define (transform-package-latest specs) |
518 | "Return a procedure that rewrites package graphs such that those in SPECS | |
519 | are replaced by their latest upstream version." | |
520 | (define (package-with-latest-upstream p) | |
521 | (let ((source (package-latest-release* p))) | |
522 | (cond ((not source) | |
523 | (warning | |
524 | (G_ "could not determine latest upstream release of '~a'~%") | |
525 | (package-name p)) | |
526 | p) | |
527 | ((string=? (upstream-source-version source) | |
528 | (package-version p)) | |
529 | p) | |
530 | (else | |
531 | (unless (pair? (upstream-source-signature-urls source)) | |
532 | (warning (G_ "cannot authenticate source of '~a', version ~a~%") | |
533 | (package-name p) | |
534 | (upstream-source-version source))) | |
535 | ||
536 | ;; TODO: Take 'upstream-source-input-changes' into account. | |
537 | (package | |
538 | (inherit p) | |
539 | (version (upstream-source-version source)) | |
540 | (source source)))))) | |
541 | ||
542 | (define rewrite | |
543 | (package-input-rewriting/spec | |
544 | (map (lambda (spec) | |
545 | (cons spec package-with-latest-upstream)) | |
546 | specs))) | |
547 | ||
548 | (lambda (obj) | |
549 | (if (package? obj) | |
550 | (rewrite obj) | |
551 | obj))) | |
552 | ||
f68b3ba1 LC |
553 | (define %transformations |
554 | ;; Transformations that can be applied to things to build. The car is the | |
555 | ;; key used in the option alist, and the cdr is the transformation | |
556 | ;; procedure; it is called with two arguments: the store, and a list of | |
557 | ;; things to build. | |
558 | `((with-source . ,transform-package-source) | |
559 | (with-input . ,transform-package-inputs) | |
560 | (with-graft . ,transform-package-inputs/graft) | |
561 | (with-branch . ,transform-package-source-branch) | |
562 | (with-commit . ,transform-package-source-commit) | |
563 | (with-git-url . ,transform-package-source-git-url) | |
564 | (with-c-toolchain . ,transform-package-toolchain) | |
565 | (with-debug-info . ,transform-package-with-debug-info) | |
e38d90d4 | 566 | (without-tests . ,transform-package-tests) |
9ab817b2 LC |
567 | (with-patch . ,transform-package-patches) |
568 | (with-latest . ,transform-package-latest))) | |
f68b3ba1 LC |
569 | |
570 | (define (transformation-procedure key) | |
571 | "Return the transformation procedure associated with KEY, a symbol such as | |
572 | 'with-source', or #f if there is none." | |
573 | (any (match-lambda | |
574 | ((k . proc) | |
575 | (and (eq? k key) proc))) | |
576 | %transformations)) | |
577 | ||
578 | \f | |
579 | ;;; | |
580 | ;;; Command-line handling. | |
581 | ;;; | |
582 | ||
583 | (define %transformation-options | |
584 | ;; The command-line interface to the above transformations. | |
585 | (let ((parser (lambda (symbol) | |
586 | (lambda (opt name arg result . rest) | |
587 | (apply values | |
588 | (alist-cons symbol arg result) | |
589 | rest))))) | |
590 | (list (option '("with-source") #t #f | |
591 | (parser 'with-source)) | |
592 | (option '("with-input") #t #f | |
593 | (parser 'with-input)) | |
594 | (option '("with-graft") #t #f | |
595 | (parser 'with-graft)) | |
596 | (option '("with-branch") #t #f | |
597 | (parser 'with-branch)) | |
598 | (option '("with-commit") #t #f | |
599 | (parser 'with-commit)) | |
600 | (option '("with-git-url") #t #f | |
601 | (parser 'with-git-url)) | |
602 | (option '("with-c-toolchain") #t #f | |
603 | (parser 'with-c-toolchain)) | |
604 | (option '("with-debug-info") #t #f | |
605 | (parser 'with-debug-info)) | |
606 | (option '("without-tests") #t #f | |
e79ecff0 | 607 | (parser 'without-tests)) |
e38d90d4 LC |
608 | (option '("with-patch") #t #f |
609 | (parser 'with-patch)) | |
9ab817b2 LC |
610 | (option '("with-latest") #t #f |
611 | (parser 'with-latest)) | |
f68b3ba1 | 612 | |
e79ecff0 LC |
613 | (option '("help-transform") #f #f |
614 | (lambda _ | |
615 | (format #t | |
616 | (G_ "Available package transformation options:~%")) | |
617 | (show-transformation-options-help/detailed) | |
618 | (newline) | |
619 | (exit 0)))))) | |
620 | ||
621 | (define (show-transformation-options-help/detailed) | |
f68b3ba1 LC |
622 | (display (G_ " |
623 | --with-source=[PACKAGE=]SOURCE | |
624 | use SOURCE when building the corresponding package")) | |
625 | (display (G_ " | |
626 | --with-input=PACKAGE=REPLACEMENT | |
627 | replace dependency PACKAGE by REPLACEMENT")) | |
628 | (display (G_ " | |
629 | --with-graft=PACKAGE=REPLACEMENT | |
630 | graft REPLACEMENT on packages that refer to PACKAGE")) | |
631 | (display (G_ " | |
632 | --with-branch=PACKAGE=BRANCH | |
633 | build PACKAGE from the latest commit of BRANCH")) | |
634 | (display (G_ " | |
635 | --with-commit=PACKAGE=COMMIT | |
636 | build PACKAGE from COMMIT")) | |
637 | (display (G_ " | |
638 | --with-git-url=PACKAGE=URL | |
639 | build PACKAGE from the repository at URL")) | |
e38d90d4 LC |
640 | (display (G_ " |
641 | --with-patch=PACKAGE=FILE | |
642 | add FILE to the list of patches of PACKAGE")) | |
9ab817b2 LC |
643 | (display (G_ " |
644 | --with-latest=PACKAGE | |
645 | use the latest upstream release of PACKAGE")) | |
f68b3ba1 LC |
646 | (display (G_ " |
647 | --with-c-toolchain=PACKAGE=TOOLCHAIN | |
648 | build PACKAGE and its dependents with TOOLCHAIN")) | |
649 | (display (G_ " | |
650 | --with-debug-info=PACKAGE | |
651 | build PACKAGE and preserve its debug info")) | |
652 | (display (G_ " | |
653 | --without-tests=PACKAGE | |
654 | build PACKAGE without running its tests"))) | |
655 | ||
e79ecff0 LC |
656 | (define (show-transformation-options-help) |
657 | "Show basic help for package transformation options." | |
658 | (display (G_ " | |
659 | --help-transform list package transformation options not shown here"))) | |
f68b3ba1 LC |
660 | |
661 | (define (options->transformation opts) | |
662 | "Return a procedure that, when passed an object to build (package, | |
663 | derivation, etc.), applies the transformations specified by OPTS and returns | |
664 | the resulting objects. OPTS must be a list of symbol/string pairs such as: | |
665 | ||
666 | ((with-branch . \"guile-gcrypt=master\") | |
667 | (without-tests . \"libgcrypt\")) | |
668 | ||
669 | Each symbol names a transformation and the corresponding string is an argument | |
670 | to that transformation." | |
671 | (define applicable | |
672 | ;; List of applicable transformations as symbol/procedure pairs in the | |
673 | ;; order in which they appear on the command line. | |
674 | (filter-map (match-lambda | |
675 | ((key . value) | |
676 | (match (transformation-procedure key) | |
677 | (#f | |
678 | #f) | |
679 | (transform | |
680 | ;; XXX: We used to pass TRANSFORM a list of several | |
681 | ;; arguments, but we now pass only one, assuming that | |
682 | ;; transform composes well. | |
683 | (list key value (transform (list value))))))) | |
684 | (reverse opts))) | |
685 | ||
686 | (define (package-with-transformation-properties p) | |
687 | (package/inherit p | |
688 | (properties `((transformations | |
689 | . ,(map (match-lambda | |
690 | ((key value _) | |
691 | (cons key value))) | |
692 | applicable)) | |
693 | ,@(package-properties p))))) | |
694 | ||
695 | (lambda (obj) | |
696 | (define (tagged-object new) | |
697 | (if (and (not (eq? obj new)) | |
698 | (package? new) (not (null? applicable))) | |
699 | (package-with-transformation-properties new) | |
700 | new)) | |
701 | ||
702 | (tagged-object | |
703 | (fold (match-lambda* | |
704 | (((name value transform) obj) | |
705 | (let ((new (transform obj))) | |
706 | (when (eq? new obj) | |
707 | (warning (G_ "transformation '~a' had no effect on ~a~%") | |
708 | name | |
709 | (if (package? obj) | |
710 | (package-full-name obj) | |
711 | obj))) | |
712 | new))) | |
713 | obj | |
714 | applicable)))) | |
715 | ||
716 | (define (package-transformations package) | |
717 | "Return the transformations applied to PACKAGE according to its properties." | |
718 | (match (assq-ref (package-properties package) 'transformations) | |
719 | (#f '()) | |
720 | (transformations transformations))) | |
721 | ||
722 | (define (manifest-entry-with-transformations entry) | |
723 | "Return ENTRY with an additional 'transformations' property if it's not | |
724 | already there." | |
725 | (let ((properties (manifest-entry-properties entry))) | |
726 | (if (assq 'transformations properties) | |
727 | entry | |
728 | (let ((item (manifest-entry-item entry))) | |
729 | (manifest-entry | |
730 | (inherit entry) | |
731 | (properties | |
732 | (match (and (package? item) | |
733 | (package-transformations item)) | |
734 | ((or #f '()) | |
735 | properties) | |
736 | (transformations | |
737 | `((transformations . ,transformations) | |
738 | ,@properties))))))))) |