projects/guix·blob next-master · refs

691 lines · 30.8 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2016-2017, 2019-2024, 2026 Ludovic Courtès <[email protected]>
3;;; Copyright © 2021 Marius Bakke <[email protected]>
4;;;
5;;; This file is part of GNU Guix.
6;;;
7;;; GNU Guix is free software; you can redistribute it and/or modify it
8;;; under the terms of the GNU General Public License as published by
9;;; the Free Software Foundation; either version 3 of the License, or (at
10;;; your option) any later version.
11;;;
12;;; GNU Guix is distributed in the hope that it will be useful, but
13;;; WITHOUT ANY WARRANTY; without even the implied warranty of
14;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;;; GNU General Public License for more details.
16;;;
17;;; You should have received a copy of the GNU General Public License
18;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
19
20(define-module (test-transformations)
21 #:use-module (guix tests)
22 #:use-module (guix store)
23 #:use-module ((guix gexp) #:select (lower-object))
24 #:use-module ((guix profiles)
25 #:select (package->manifest-entry
26 manifest-entry-properties))
27 #:use-module (guix derivations)
28 #:use-module (guix packages)
29 #:use-module (guix git-download)
30 #:use-module (guix build-system)
31 #:use-module (guix build-system gnu)
32 #:use-module (guix transformations)
33 #:use-module ((guix gexp)
34 #:select (local-file? local-file-file
35 computed-file? computed-file-gexp
36 gexp-input-thing gexp->approximate-sexp))
37 #:use-module (guix ui)
38 #:use-module (guix utils)
39 #:use-module (guix git)
40 #:use-module (guix upstream)
41 #:use-module (guix diagnostics)
42 #:use-module (gnu packages)
43 #:use-module (gnu packages base)
44 #:use-module (gnu packages busybox)
45 #:use-module (ice-9 match)
46 #:use-module (srfi srfi-1)
47 #:use-module (srfi srfi-26)
48 #:use-module (srfi srfi-34)
49 #:use-module (srfi srfi-64))
50
51
52(test-begin "transformations")
53
54(test-assert "options->transformation, no transformations"
55 (let ((p (dummy-package "foo"))
56 (t (options->transformation '())))
57 (eq? (t p) p)))
58
59(test-assert "options->transformation, with-source"
60 ;; Our pseudo-package is called 'guix.scm' so the 'guix.scm' source should
61 ;; be applicable.
62 (let* ((p (dummy-package "guix.scm"))
63 (s (search-path %load-path "guix.scm"))
64 (t (options->transformation `((with-source . ,s)))))
65 (with-store store
66 (let* ((new (t p))
67 (source (run-with-store store
68 (lower-object (package-source new)))))
69 (and (not (eq? new p))
70 (string=? source
71 (add-to-store store "guix.scm" #t
72 "sha256" s)))))))
73
74(test-assert "options->transformation, with-source, replacement"
75 ;; Same, but this time the original package has a 'replacement' field. We
76 ;; expect that replacement to be set to #f in the new package.
77 (let* ((p (dummy-package "guix.scm" (replacement coreutils)))
78 (s (search-path %load-path "guix.scm"))
79 (t (options->transformation `((with-source . ,s)))))
80 (let ((new (t p)))
81 (and (not (eq? new p))
82 (not (package-replacement new))))))
83
84(test-assert "options->transformation, with-source, with version"
85 ;; Our pseudo-package is called 'guix.scm' so the 'guix.scm-2.0' source
86 ;; should be applicable, and its version should be extracted.
87 (let ((p (dummy-package "foo"))
88 (s (search-path %load-path "guix.scm")))
89 (call-with-temporary-directory
90 (lambda (directory)
91 (let* ((f (string-append directory "/foo-42.0.tar.gz"))
92 (t (options->transformation `((with-source . ,f)))))
93 (copy-file s f)
94 (with-store store
95 (let* ((new (t p))
96 (source (run-with-store store
97 (lower-object (package-source new)))))
98 (and (not (eq? new p))
99 (string=? (package-name new) (package-name p))
100 (string=? (package-version new) "42.0")
101 (string=? source
102 (add-to-store store (basename f) #t
103 "sha256" f))))))))))
104
105(test-assert "options->transformation, with-source, no matches"
106 (let* ((p (dummy-package "foobar"))
107 (s (search-path %load-path "guix.scm"))
108 (t (options->transformation `((with-source . ,s)))))
109 (eq? (package-source (t p))
110 (package-source p))))
111
112(test-assert "options->transformation, with-source, PKG=URI"
113 (let* ((p (dummy-package "foo"))
114 (s (search-path %load-path "guix.scm"))
115 (f (string-append "foo=" s))
116 (t (options->transformation `((with-source . ,f)))))
117 (with-store store
118 (let* ((new (t p))
119 (source (run-with-store store
120 (lower-object (package-source new)))))
121 (and (not (eq? new p))
122 (string=? (package-name new) (package-name p))
123 (string=? (package-version new)
124 (package-version p))
125 (string=? source
126 (add-to-store store (basename s) #t
127 "sha256" s)))))))
128
129(test-assert "options->transformation, with-source, PKG@VER=URI"
130 (let* ((p (dummy-package "foo"))
131 (s (search-path %load-path "guix.scm"))
132 (f (string-append "[email protected]=" s))
133 (t (options->transformation `((with-source . ,f)))))
134 (with-store store
135 (let* ((new (t p))
136 (source (run-with-store store
137 (lower-object (package-source new)))))
138 (and (not (eq? new p))
139 (string=? (package-name new) (package-name p))
140 (string=? (package-version new) "42.0")
141 (string=? source
142 (add-to-store store (basename s) #t
143 "sha256" s)))))))
144
145(test-assert "options->transformation, with-source, in depth"
146 (let* ((p0 (dummy-package "foo" (version "0.0")))
147 (s (search-path %load-path "guix.scm"))
148 (f (string-append "[email protected]=" s))
149 (t (options->transformation `((with-source . ,f))))
150 (p1 (dummy-package "bar" (inputs (list p0))))
151 (p2 (dummy-package "baz" (inputs (list p1)))))
152 (with-store store
153 (let ((new (t p2)))
154 (and (not (eq? new p2))
155 (match (package-inputs new)
156 ((("bar" p1*))
157 (match (package-inputs p1*)
158 ((("foo" p0*))
159 (and (not (eq? p0* p0))
160 (string=? (package-name p0*) (package-name p0))
161 (string=? (package-version p0*) "42.0")
162 (string=? (add-to-store store (basename s) #t
163 "sha256" s)
164 (run-with-store store
165 (lower-object
166 (package-source p0*))))))))))))))
167
168(test-assert "options->transformation, with-input"
169 (let* ((p (dummy-package "guix.scm"
170 (inputs `(("foo" ,(specification->package "coreutils"))
171 ("bar" ,(specification->package "grep"))
172 ("baz" ,(dummy-package "chbouib"
173 (native-inputs `(("x" ,grep)))))))))
174 (t (options->transformation '((with-input . "coreutils=busybox")
175 (with-input . "grep=findutils")))))
176 (let ((new (t p)))
177 (and (not (eq? new p))
178 (match (package-inputs new)
179 ((("foo" dep1) ("bar" dep2) ("baz" dep3))
180 (and (string=? (package-full-name dep1)
181 (package-full-name busybox))
182 (string=? (package-full-name dep2)
183 (package-full-name findutils))
184 (string=? (package-name dep3) "chbouib")
185 (match (package-native-inputs dep3)
186 ((("x" dep))
187 (string=? (package-full-name dep)
188 (package-full-name findutils)))))))))))
189
190;; The following test requires grafting enabled, but it becomes extremely
191;; expensive if there's a graft on glibc or other package deep in the graph.
192(when (package-replacement (@ (gnu packages commencement) glibc-final))
193 (test-skip 1))
194
195(test-assert "options->transformation, with-graft"
196 (let* ((p (dummy-package "guix.scm"
197 (inputs `(("foo" ,grep)
198 ("bar" ,(dummy-package "chbouib"
199 (native-inputs `(("x" ,grep)))))))))
200 (t (options->transformation '((with-graft . "grep=findutils")))))
201 (let ((new (t p)))
202 (and (not (eq? new p))
203 (match (package-inputs new)
204 ((("foo" dep1) ("bar" dep2))
205 (and (string=? (package-full-name dep1)
206 (package-full-name grep))
207 (string=? (package-full-name (package-replacement dep1))
208 (package-full-name findutils))
209 (string=? (package-name dep2) "chbouib")
210 (match (package-native-inputs dep2)
211 ((("x" dep))
212 (with-store store
213 (string=? (derivation-file-name
214 (package-derivation store findutils))
215 (derivation-file-name
216 (package-derivation store dep)))))))))))))
217
218(test-equal "options->transformation, with-branch"
219 (git-checkout (url "https://example.org")
220 (branch "devel"))
221 (let* ((p (dummy-package "guix.scm"
222 (inputs `(("foo" ,grep)
223 ("bar" ,(dummy-package "chbouib"
224 (source (origin
225 (method git-fetch)
226 (uri (git-reference
227 (url "https://example.org")
228 (commit "cabba9e")))
229 (sha256 #f)))))))))
230 (t (options->transformation '((with-branch . "chbouib=devel")))))
231 (let ((new (t p)))
232 (and (not (eq? new p))
233 (match (package-inputs new)
234 ((("foo" dep1) ("bar" dep2))
235 (and (string=? (package-full-name dep1)
236 (package-full-name grep))
237 (string=? (package-name dep2) "chbouib")
238 (package-source dep2))))))))
239
240(test-equal "options->transformation, with-branch, recursive? inheritance"
241 (git-checkout (url "https://example.org")
242 (branch "devel")
243 (recursive? #t))
244 (let* ((p (dummy-package "guix.scm"
245 (inputs `(("foo" ,grep)
246 ("bar" ,(dummy-package "chbouib"
247 (source (origin
248 (method git-fetch)
249 (uri (git-reference
250 (url "https://example.org")
251 (commit "cabba9e")
252 (recursive? #t)))
253 (sha256 #f)))))))))
254 (t (options->transformation '((with-branch . "chbouib=devel")))))
255 (let ((new (t p)))
256 (and (not (eq? new p))
257 (match (package-inputs new)
258 ((("foo" dep1) ("bar" dep2))
259 (and (string=? (package-full-name dep1)
260 (package-full-name grep))
261 (string=? (package-name dep2) "chbouib")
262 (package-source dep2))))))))
263
264(test-equal "options->transformation, with-commit"
265 (git-checkout (url "https://example.org")
266 (commit "abcdef"))
267 (let* ((p (dummy-package "guix.scm"
268 (inputs `(("foo" ,grep)
269 ("bar" ,(dummy-package "chbouib"
270 (source (origin
271 (method git-fetch)
272 (uri (git-reference
273 (url "https://example.org")
274 (commit "cabba9e")))
275 (sha256 #f)))))))))
276 (t (options->transformation '((with-commit . "chbouib=abcdef")))))
277 (let ((new (t p)))
278 (and (not (eq? new p))
279 (match (package-inputs new)
280 ((("foo" dep1) ("bar" dep2))
281 (and (string=? (package-full-name dep1)
282 (package-full-name grep))
283 (string=? (package-name dep2) "chbouib")
284 (package-source dep2))))))))
285
286(test-equal "options->transformation, with-commit, recursive? inheritance"
287 (git-checkout (url "https://example.org")
288 (commit "abcdef")
289 (recursive? #t))
290 (let* ((p (dummy-package "guix.scm"
291 (inputs `(("foo" ,grep)
292 ("bar" ,(dummy-package "chbouib"
293 (source (origin
294 (method git-fetch)
295 (uri (git-reference
296 (url "https://example.org")
297 (commit "cabba9e")
298 (recursive? #t)))
299 (sha256 #f)))))))))
300 (t (options->transformation '((with-commit . "chbouib=abcdef")))))
301 (let ((new (t p)))
302 (and (not (eq? new p))
303 (match (package-inputs new)
304 ((("foo" dep1) ("bar" dep2))
305 (and (string=? (package-full-name dep1)
306 (package-full-name grep))
307 (string=? (package-name dep2) "chbouib")
308 (package-source dep2))))))))
309
310(test-equal "options->transformation, with-commit, version transformation"
311 '("1.0" "1.0-rc1-2-gabc123" "git.abc123")
312 (map (lambda (commit)
313 (let* ((p (dummy-package "guix.scm"
314 (inputs `(("foo" ,(dummy-package "chbouib"
315 (source (origin
316 (method git-fetch)
317 (uri (git-reference
318 (url "https://example.org")
319 (commit "cabba9e")))
320 (sha256 #f)))))))))
321 (t (options->transformation
322 `((with-commit . ,(string-append "chbouib=" commit))))))
323 (let ((new (t p)))
324 (and (not (eq? new p))
325 (match (package-inputs new)
326 ((("foo" dep1))
327 (package-version dep1)))))))
328 '("v1.0" "1.0-rc1-2-gabc123" "abc123")))
329
330(test-equal "options->transformation, with-git-url"
331 (let ((source (git-checkout (url "https://example.org")
332 (recursive? #t))))
333 (list source source))
334 (let* ((p (dummy-package "guix.scm"
335 (inputs `(("foo" ,grep)
336 ("bar" ,(dummy-package "chbouib"
337 (native-inputs `(("x" ,grep)))))))))
338 (t (options->transformation '((with-git-url . "grep=https://example.org")))))
339 (let ((new (t p)))
340 (and (not (eq? new p))
341 (match (package-inputs new)
342 ((("foo" dep1) ("bar" dep2))
343 (and (string=? (package-full-name dep1)
344 (package-full-name grep))
345 (string=? (package-name dep2) "chbouib")
346 (match (package-native-inputs dep2)
347 ((("x" dep3))
348 (map package-source (list dep1 dep3)))))))))))
349
350(test-equal "options->transformation, with-git-url + with-branch"
351 ;; Combine the two options and make sure the 'with-branch' transformation
352 ;; comes after the 'with-git-url' transformation.
353 (let ((source (git-checkout (url "https://example.org")
354 (branch "BRANCH")
355 (recursive? #t))))
356 (list source source))
357 (let* ((p (dummy-package "guix.scm"
358 (inputs `(("foo" ,grep)
359 ("bar" ,(dummy-package "chbouib"
360 (native-inputs `(("x" ,grep)))))))))
361 (t (options->transformation
362 (reverse '((with-git-url
363 . "grep=https://example.org")
364 (with-branch . "grep=BRANCH"))))))
365 (let ((new (t p)))
366 (and (not (eq? new p))
367 (match (package-inputs new)
368 ((("foo" dep1) ("bar" dep2))
369 (and (string=? (package-name dep1) "grep")
370 (string=? (package-name dep2) "chbouib")
371 (match (package-native-inputs dep2)
372 ((("x" dep3))
373 (map package-source (list dep1 dep3)))))))))))
374
375(define* (depends-on-toolchain? p #:optional (toolchain "gcc-toolchain"))
376 "Return true if P depends on TOOLCHAIN instead of the default tool chain."
377 (define toolchain-packages
378 '("gcc" "binutils" "glibc" "ld-wrapper"))
379
380 (define (package-name* obj)
381 (and (package? obj) (package-name obj)))
382
383 (match (bag-build-inputs (package->bag p))
384 (((_ (= package-name* packages) . _) ...)
385 (and (not (any (cut member <> packages) toolchain-packages))
386 (member toolchain packages)))))
387
388(test-assert "options->transformation, with-c-toolchain"
389 (let* ((dep0 (dummy-package "chbouib"
390 (build-system gnu-build-system)
391 (native-inputs `(("y" ,grep)))))
392 (dep1 (dummy-package "stuff"
393 (native-inputs `(("x" ,dep0)))))
394 (p (dummy-package "thingie"
395 (build-system gnu-build-system)
396 (inputs `(("foo" ,grep)
397 ("bar" ,dep1)))))
398 (t (options->transformation
399 '((with-c-toolchain . "chbouib=gcc-toolchain")))))
400 ;; Here we check that the transformation applies to DEP0 and all its
401 ;; dependents: DEP0 must use GCC-TOOLCHAIN, DEP1 must use GCC-TOOLCHAIN
402 ;; and the DEP0 that uses GCC-TOOLCHAIN, and so on.
403 (let ((new (t p)))
404 (and (depends-on-toolchain? new "gcc-toolchain")
405 (match (bag-build-inputs (package->bag new))
406 ((("foo" dep0) ("bar" dep1) _ ...)
407 (and (depends-on-toolchain? dep1 "gcc-toolchain")
408 (not (depends-on-toolchain? dep0 "gcc-toolchain"))
409 (string=? (package-full-name dep0)
410 (package-full-name grep))
411 (match (bag-build-inputs (package->bag dep1))
412 ((("x" dep) _ ...)
413 (and (depends-on-toolchain? dep "gcc-toolchain")
414 (match (bag-build-inputs (package->bag dep))
415 ((("y" dep) _ ...) ;this one is unchanged
416 (eq? dep grep)))))))))))))
417
418(test-equal "options->transformation, with-c-toolchain twice"
419 (package-full-name grep)
420 (let* ((dep0 (dummy-package "chbouib"))
421 (dep1 (dummy-package "stuff"))
422 (p (dummy-package "thingie"
423 (build-system gnu-build-system)
424 (inputs `(("foo" ,dep0)
425 ("bar" ,dep1)
426 ("baz" ,grep)))))
427 (t (options->transformation
428 '((with-c-toolchain . "chbouib=clang-toolchain")
429 (with-c-toolchain . "stuff=clang-toolchain")))))
430 (let ((new (t p)))
431 (and (depends-on-toolchain? new "clang-toolchain")
432 (match (bag-build-inputs (package->bag new))
433 ((("foo" dep0) ("bar" dep1) ("baz" dep2) _ ...)
434 (and (depends-on-toolchain? dep0 "clang-toolchain")
435 (depends-on-toolchain? dep1 "clang-toolchain")
436 (not (depends-on-toolchain? dep2 "clang-toolchain"))
437 (package-full-name dep2))))))))
438
439(test-assert "options->transformation, with-c-toolchain, no effect"
440 (let ((p (dummy-package "thingie"))
441 (t (options->transformation
442 '((with-c-toolchain . "does-not-exist=gcc-toolchain")))))
443 ;; When it has no effect, '--with-c-toolchain' returns P.
444 (eq? (t p) p)))
445
446(test-equal "options->transformation, with-debug-info"
447 '(#:strip-binaries? #f)
448 (let* ((dep (dummy-package "chbouib"))
449 (p (dummy-package "thingie"
450 (build-system gnu-build-system)
451 (inputs `(("foo" ,dep)
452 ("bar" ,grep)))))
453 (t (options->transformation
454 '((with-debug-info . "chbouib")))))
455 (let ((new (t p)))
456 (match (package-inputs new)
457 ((("foo" dep0) ("bar" dep1))
458 (and (string=? (package-full-name dep1)
459 (package-full-name grep))
460 (package-arguments (package-replacement dep0))))))))
461
462(test-equal "options->transformation, with-configure-flag"
463 '(append '() '("--flag=42"))
464 (let* ((p (dummy-package "foo"
465 (build-system gnu-build-system)))
466 (t (options->transformation
467 '((with-configure-flag . "foo=--flag=42")))))
468 (let ((new (t p)))
469 (match (package-arguments new)
470 ((#:configure-flags flags)
471 (gexp->approximate-sexp flags))))))
472
473(test-assert "options->transformation, without-tests"
474 (let* ((dep (dummy-package "dep"))
475 (p (dummy-package "foo"
476 (inputs `(("dep" ,dep)))))
477 (t (options->transformation '((without-tests . "dep")
478 (without-tests . "tar")))))
479 (let ((new (t p)))
480 (match (bag-direct-inputs (package->bag new))
481 ((("dep" dep) ("tar" tar) _ ...)
482 (and (equal? (package-arguments dep) '(#:tests? #f))
483 (match (memq #:tests? (package-arguments tar))
484 ((#:tests? #f _ ...) #t))))))))
485
486(test-equal "options->transformation, with-patch"
487 (search-patches "glibc-locales.patch" "guile-relocatable.patch")
488 (let* ((dep (dummy-package "dep"
489 (source (dummy-origin))))
490 (p (dummy-package "foo"
491 (inputs `(("dep" ,dep)))))
492 (patch1 (search-patch "glibc-locales.patch"))
493 (patch2 (search-patch "guile-relocatable.patch"))
494 (t (options->transformation
495 `((with-patch . ,(string-append "dep=" patch1))
496 (with-patch . ,(string-append "dep=" patch2))
497 (with-patch . ,(string-append "tar=" patch1))))))
498 (let ((new (t p)))
499 (match (bag-direct-inputs (package->bag new))
500 ((("dep" dep) ("tar" tar) _ ...)
501 (and (member patch1
502 (filter-map (lambda (patch)
503 (and (local-file? patch)
504 (local-file-file patch)))
505 (origin-patches (package-source tar))))
506 (map local-file-file
507 (origin-patches (package-source dep)))))))))
508
509(test-equal "options->transformation, with-commit + with-patch"
510 '(#t #t)
511 (let* ((patch (search-patch "glibc-locales.patch"))
512 (commit "f8934ec94df5868ee8baf1fb0f8ed0f24e7e91eb")
513 (t (options->transformation
514 ;; Note: options are applied in reverse order, so
515 ;; 'with-patch' comes on top.
516 `((with-patch . ,(string-append "guile-gcrypt=" patch))
517 (with-commit
518 . ,(string-append "guile-gcrypt=" commit))))))
519 (let ((new (t (@ (gnu packages gnupg) guile-gcrypt))))
520 (match (package-source new)
521 ((? computed-file? source)
522 (let* ((gexp (computed-file-gexp source))
523 (inputs (map gexp-input-thing
524 ((@@ (guix gexp) gexp-inputs) gexp))))
525 (list (any (lambda (input)
526 (and (git-checkout? input)
527 (string=? commit (git-checkout-commit input))))
528 inputs)
529 (any (lambda (input)
530 (and (local-file? input)
531 (string=? (local-file-file input) patch)))
532 inputs))))))))
533
534(test-equal "options->transformation, property order"
535 ;; See <https://issues.guix.gnu.org/54942>.
536 '((with-debug-info . "does-not-exist")
537 (with-commit . "does-not-exist=aaaaaaa")
538 (without-tests . "does-not-exist"))
539 (let* ((t (options->transformation
540 '((with-debug-info . "does-not-exist")
541 (with-commit . "does-not-exist=aaaaaaa")
542 (without-tests . "does-not-exist")))))
543 (let ((new (t coreutils)))
544 (assq-ref (package-properties new) 'transformations))))
545
546(test-equal "package-with-upstream-version"
547 '("42.0" "42.0"
548 ("http://example.org")
549 ("a" "b") (do something))
550 (mock ((guix upstream) %updaters
551 (delay (list (upstream-updater
552 (name 'dummy)
553 (pred (const #t))
554 (description "")
555 (import (const (upstream-source
556 (package "foo")
557 (version "42.0")
558 (urls '("http://example.org")))))))))
559 (let* ((old (dummy-package "foo" (version "1.0")
560 (source (dummy-origin
561 (patches '("a" "b"))
562 (snippet '(do something))))))
563 (new (package-with-upstream-version old))
564 (new+patches (package-with-upstream-version
565 old #:preserve-patches? #t)))
566 (list (package-version new) (package-version new+patches)
567
568 ;; Source of NEW is directly an <upstream-source>.
569 (upstream-source-urls (package-source new))
570
571 ;; Check that #:preserve-patches? #t gave us an origin.
572 (origin-patches (package-source new+patches))
573 (origin-snippet (package-source new+patches))))))
574
575(test-equal "options->transformation, with-latest"
576 "42.0"
577 (mock ((guix upstream) %updaters
578 (delay (list (upstream-updater
579 (name 'dummy)
580 (pred (const #t))
581 (description "")
582 (import (const (upstream-source
583 (package "foo")
584 (version "42.0")
585 (urls '("http://example.org")))))))))
586 (let* ((p (dummy-package "foo" (version "1.0")))
587 (t (options->transformation
588 `((with-latest . "foo")))))
589 (package-version (t p)))))
590
591(test-equal "options->transformation, with-version"
592 "1.0"
593 (mock ((guix upstream) %updaters
594 (delay (list (upstream-updater
595 (name 'dummy)
596 (pred (const #t))
597 (description "")
598 (import (const (upstream-source
599 (package "foo")
600 (version "1.0")
601 (urls '("http://example.org")))))))))
602 (let* ((p0 (dummy-package "foo" (version "7.7")))
603 (p1 (dummy-package "bar" (inputs (list p0))))
604 (t (options->transformation
605 `((with-version . "foo=1.0")))))
606 (package-version (lookup-package-input (t p1) "foo")))))
607
608(test-equal "options->transformation, tune"
609 '(cpu-tuning . "superfast")
610 (let* ((p0 (dummy-package "p0"))
611 (p1 (dummy-package "p1"
612 (inputs `(("p0" ,p0)))
613 (properties '((tunable? . #t)))))
614 (p2 (dummy-package "p2"
615 (inputs `(("p1" ,p1)))))
616 (t (options->transformation '((tune . "superfast"))))
617 (p3 (t p2)))
618 (and (not (package-replacement p3))
619 (match (package-inputs p3)
620 ((("p1" tuned))
621 (match (package-inputs tuned)
622 ((("p0" p0))
623 (and (not (package-replacement p0))
624 (assq 'cpu-tuning
625 (package-properties
626 (package-replacement tuned)))))))))))
627
628(test-assert "options->transformations, tune, wrong micro-architecture"
629 (let ((p (dummy-package "tunable"
630 (properties '((tunable? . #t)))))
631 (t (options->transformation '((tune . "nonexistent-superfast")))))
632 ;; Because GCC used by P's build system does not support
633 ;; '-march=nonexistent-superfast', we should see an error when lowering
634 ;; the tuned package.
635 (guard (c ((formatted-message? c)
636 (member "nonexistent-superfast"
637 (formatted-message-arguments c))))
638 (package->bag (t p))
639 #f)))
640
641(test-equal "options->transformations, amd-gpu"
642 '("gfx90a" "gfx942")
643 (let ((p (dummy-package "amd-gpu-code"
644 (native-inputs
645 (list (@ (gnu packages llvm) clang-rocm)))
646 (properties '((amd-gpu-targets . ("whatever"))))))
647 (t (options->transformation '((amd-gpu . ("gfx90a" "gfx942"))))))
648 (assoc-ref (package-properties (t p)) 'amd-gpu-targets)))
649
650(test-equal "options->transformations, amd-gpu, not applicable"
651 #f
652 (let ((p (dummy-package "not-amd-gpu-code"))
653 (t (options->transformation '((amd-gpu . ("gfx90a" "gfx942"))))))
654 (assoc-ref (package-properties (t p)) 'amd-gpu-targets)))
655
656(test-assert "options->transformations, amd-gpu, missing clang-rocm input"
657 (let ((p (dummy-package "amd-gpu-code"
658 (properties '((amd-gpu-targets . ("whatever"))))))
659 (t (options->transformation '((amd-gpu . ("generic"))))))
660 ;; Since 'clang-rocm' is not among the inputs, an error should be raised.
661 (guard (c ((formatted-message? c)
662 (string-contains (formatted-message-string c)
663 "no ROCm compiler")))
664 (t p)
665 #f)))
666
667(test-assert "options->transformations, amd-gpu, wrong GPU"
668 (let ((p (dummy-package "amd-gpu-code"
669 (native-inputs
670 (list (@ (gnu packages llvm) clang-rocm)))
671 (properties '((amd-gpu-targets . ("whatever"))))))
672 (t (options->transformation '((amd-gpu . ("does-not-exist"))))))
673 ;; Since this AMD GPU target is not known to 'clang-rocm', an error should
674 ;; be raised.
675 (guard (c ((formatted-message? c)
676 (member "does-not-exist" (formatted-message-arguments c))))
677 (t p)
678 #f)))
679
680(test-equal "options->transformation + package->manifest-entry"
681 '((transformations . ((without-tests . "foo"))))
682 (let* ((p (dummy-package "foo"))
683 (t (options->transformation '((without-tests . "foo"))))
684 (e (package->manifest-entry (t p))))
685 (manifest-entry-properties e)))
686
687(test-end)
688
689;;; Local Variables:
690;;; eval: (put 'dummy-package 'scheme-indent-function 1)
691;;; End: