transformations.scm 38 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989
  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2016-2022 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2021 Marius Bakke <marius@gnu.org>
  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. (define-module (guix transformations)
  20. #:use-module ((guix config) #:select (%system))
  21. #:use-module (guix i18n)
  22. #:use-module (guix store)
  23. #:use-module (guix packages)
  24. #:use-module (guix build-system)
  25. #:use-module (guix profiles)
  26. #:use-module (guix diagnostics)
  27. #:autoload (guix download) (download-to-store)
  28. #:autoload (guix git-download) (git-reference? git-reference-url)
  29. #:autoload (guix git) (git-checkout git-checkout? git-checkout-url)
  30. #:autoload (guix upstream) (package-latest-release
  31. upstream-source-version
  32. upstream-source-signature-urls)
  33. #:autoload (guix cpu) (current-cpu cpu->gcc-architecture)
  34. #:use-module (guix utils)
  35. #:use-module (guix memoization)
  36. #:use-module (guix gexp)
  37. ;; Use the procedure that destructures "NAME-VERSION" forms.
  38. #:use-module ((guix build utils)
  39. #:select ((package-name->name+version
  40. . hyphen-package-name->name+version)))
  41. #:use-module (srfi srfi-1)
  42. #:use-module (srfi srfi-9)
  43. #:use-module (srfi srfi-11)
  44. #:use-module (srfi srfi-26)
  45. #:use-module (srfi srfi-34)
  46. #:use-module (srfi srfi-37)
  47. #:use-module (ice-9 match)
  48. #:use-module (ice-9 vlist)
  49. #:export (options->transformation
  50. manifest-entry-with-transformations
  51. tunable-package?
  52. tuned-package
  53. show-transformation-options-help
  54. transformation-option-key?
  55. %transformation-options))
  56. ;;; Commentary:
  57. ;;;
  58. ;;; This module implements "package transformation options"---tools for
  59. ;;; package graph rewriting. It contains the graph rewriting logic, but also
  60. ;;; the tip of its user interface: command-line option handling.
  61. ;;;
  62. ;;; Code:
  63. (module-autoload! (current-module) '(gnu packages)
  64. '(specification->package))
  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. (define (tarball-base-name file-name)
  69. "Return the \"base\" of FILE-NAME, removing '.tar.gz' or similar
  70. extensions."
  71. ;; TODO: Factorize.
  72. (cond ((not (file-extension file-name))
  73. file-name)
  74. ((numeric-extension? file-name)
  75. file-name)
  76. ((string=? (file-extension file-name) "tar")
  77. (file-sans-extension file-name))
  78. ((file-extension file-name)
  79. =>
  80. (match-lambda
  81. ("scm" file-name)
  82. (_ (tarball-base-name (file-sans-extension file-name)))))
  83. (else
  84. file-name)))
  85. ;; Files to be downloaded.
  86. (define-record-type <downloaded-file>
  87. (downloaded-file uri recursive?)
  88. downloaded-file?
  89. (uri downloaded-file-uri)
  90. (recursive? downloaded-file-recursive?))
  91. (define download-to-store*
  92. (store-lift download-to-store))
  93. (define-gexp-compiler (compile-downloaded-file (file <downloaded-file>)
  94. system target)
  95. "Download FILE and return the result as a store item."
  96. (match file
  97. (($ <downloaded-file> uri recursive?)
  98. (download-to-store* uri #:recursive? recursive?))))
  99. (define* (package-with-source p uri #:optional version)
  100. "Return a package based on P but with its source taken from URI. Extract
  101. the new package's version number from URI."
  102. (let ((base (tarball-base-name (basename uri))))
  103. (let-values (((_ version*)
  104. (hyphen-package-name->name+version base)))
  105. (package (inherit p)
  106. (version (or version version*
  107. (package-version p)))
  108. ;; Use #:recursive? #t to allow for directories.
  109. (source (downloaded-file uri #t))))))
  110. ;;;
  111. ;;; Transformations.
  112. ;;;
  113. (define (transform-package-source sources)
  114. "Return a transformation procedure that replaces package sources with the
  115. matching URIs given in SOURCES."
  116. (define new-sources
  117. (map (lambda (uri)
  118. (match (string-index uri #\=)
  119. (#f
  120. ;; Determine the package name and version from URI.
  121. (call-with-values
  122. (lambda ()
  123. (hyphen-package-name->name+version
  124. (tarball-base-name (basename uri))))
  125. (lambda (name version)
  126. (list name version uri))))
  127. (index
  128. ;; What's before INDEX is a "PKG@VER" or "PKG" spec.
  129. (call-with-values
  130. (lambda ()
  131. (package-name->name+version (string-take uri index)))
  132. (lambda (name version)
  133. (list name version
  134. (string-drop uri (+ 1 index))))))))
  135. sources))
  136. (lambda (obj)
  137. (let loop ((sources new-sources)
  138. (result '()))
  139. (match obj
  140. ((? package? p)
  141. (match (assoc-ref sources (package-name p))
  142. ((version source)
  143. (package-with-source p source version))
  144. (#f
  145. p)))
  146. (_
  147. obj)))))
  148. (define (evaluate-replacement-specs specs proc)
  149. "Parse SPECS, a list of strings like \"guile=guile@2.1\" and return a list
  150. of package spec/procedure pairs as expected by 'package-input-rewriting/spec'.
  151. PROC is called with the package to be replaced and its replacement according
  152. to SPECS. Raise an error if an element of SPECS uses invalid syntax, or if a
  153. package it refers to could not be found."
  154. (define not-equal
  155. (char-set-complement (char-set #\=)))
  156. (map (lambda (spec)
  157. (match (string-tokenize spec not-equal)
  158. ((spec new)
  159. (cons spec
  160. (let ((new (specification->package new)))
  161. (lambda (old)
  162. (proc old new)))))
  163. (x
  164. (raise (formatted-message
  165. (G_ "invalid replacement specification: ~s")
  166. spec)))))
  167. specs))
  168. (define (transform-package-inputs replacement-specs)
  169. "Return a procedure that, when passed a package, replaces its direct
  170. dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
  171. strings like \"guile=guile@2.1\" meaning that, any dependency on a package
  172. called \"guile\" must be replaced with a dependency on a version 2.1 of
  173. \"guile\"."
  174. (let* ((replacements (evaluate-replacement-specs replacement-specs
  175. (lambda (old new)
  176. new)))
  177. (rewrite (package-input-rewriting/spec replacements)))
  178. (lambda (obj)
  179. (if (package? obj)
  180. (rewrite obj)
  181. obj))))
  182. (define (transform-package-inputs/graft 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 \"gnutls=gnutls@3.5.4\" meaning that packages are built using the
  186. current 'gnutls' package, after which version 3.5.4 is grafted onto them."
  187. (define (set-replacement old new)
  188. (package (inherit old) (replacement new)))
  189. (let* ((replacements (evaluate-replacement-specs replacement-specs
  190. set-replacement))
  191. (rewrite (package-input-rewriting/spec replacements)))
  192. (lambda (obj)
  193. (if (package? obj)
  194. (rewrite obj)
  195. obj))))
  196. (define %not-equal
  197. (char-set-complement (char-set #\=)))
  198. (define (package-git-url package)
  199. "Return the URL of the Git repository for package, or raise an error if
  200. the source of PACKAGE is not fetched from a Git repository."
  201. (let ((source (package-source package)))
  202. (cond ((and (origin? source)
  203. (git-reference? (origin-uri source)))
  204. (git-reference-url (origin-uri source)))
  205. ((git-checkout? source)
  206. (git-checkout-url source))
  207. (else
  208. (raise
  209. (formatted-message (G_ "the source of ~a is not a Git reference")
  210. (package-full-name package)))))))
  211. (define (evaluate-git-replacement-specs specs proc)
  212. "Parse SPECS, a list of strings like \"guile=stable-2.2\", and return a list
  213. of package pairs, where (PROC PACKAGE URL BRANCH-OR-COMMIT) returns the
  214. replacement package. Raise an error if an element of SPECS uses invalid
  215. syntax, or if a package it refers to could not be found."
  216. (map (lambda (spec)
  217. (match (string-tokenize spec %not-equal)
  218. ((spec branch-or-commit)
  219. (define (replace old)
  220. (let* ((source (package-source old))
  221. (url (package-git-url old)))
  222. (proc old url branch-or-commit)))
  223. (cons spec replace))
  224. (_
  225. (raise
  226. (formatted-message (G_ "invalid replacement specification: ~s")
  227. spec)))))
  228. specs))
  229. (define (transform-package-source-branch replacement-specs)
  230. "Return a procedure that, when passed a package, replaces its direct
  231. dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
  232. strings like \"guile-next=stable-3.0\" meaning that packages are built using
  233. 'guile-next' from the latest commit on its 'stable-3.0' branch."
  234. (define (replace old url branch)
  235. (package
  236. (inherit old)
  237. (version (string-append "git." (string-map (match-lambda
  238. (#\/ #\-)
  239. (chr chr))
  240. branch)))
  241. (source (git-checkout (url url) (branch branch)
  242. (recursive? #t)))))
  243. (let* ((replacements (evaluate-git-replacement-specs replacement-specs
  244. replace))
  245. (rewrite (package-input-rewriting/spec replacements)))
  246. (lambda (obj)
  247. (if (package? obj)
  248. (rewrite obj)
  249. obj))))
  250. (define (commit->version-string commit)
  251. "Return a string suitable for use in the 'version' field of a package based
  252. on the given COMMIT."
  253. (cond ((and (> (string-length commit) 1)
  254. (string-prefix? "v" commit)
  255. (char-set-contains? char-set:digit
  256. (string-ref commit 1)))
  257. ;; Probably a tag like "v1.0" or a 'git describe' identifier.
  258. (string-drop commit 1))
  259. ((not (string-every char-set:hex-digit commit))
  260. ;; Pass through tags and 'git describe' style IDs directly.
  261. commit)
  262. (else
  263. (string-append "git."
  264. (if (< (string-length commit) 7)
  265. commit
  266. (string-take commit 7))))))
  267. (define (transform-package-source-commit replacement-specs)
  268. "Return a procedure that, when passed a package, replaces its direct
  269. dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
  270. strings like \"guile-next=cabba9e\" meaning that packages are built using
  271. 'guile-next' from commit 'cabba9e'."
  272. (define (replace old url commit)
  273. (package
  274. (inherit old)
  275. (version (commit->version-string commit))
  276. (source (git-checkout (url url) (commit commit)
  277. (recursive? #t)))))
  278. (let* ((replacements (evaluate-git-replacement-specs replacement-specs
  279. replace))
  280. (rewrite (package-input-rewriting/spec replacements)))
  281. (lambda (obj)
  282. (if (package? obj)
  283. (rewrite obj)
  284. obj))))
  285. (define (transform-package-source-git-url replacement-specs)
  286. "Return a procedure that, when passed a package, replaces its dependencies
  287. according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of strings like
  288. \"guile-json=https://gitthing.com/…\" meaning that packages are built using
  289. a checkout of the Git repository at the given URL."
  290. (define replacements
  291. (map (lambda (spec)
  292. (match (string-tokenize spec %not-equal)
  293. ((spec url)
  294. (cons spec
  295. (lambda (old)
  296. (package
  297. (inherit old)
  298. (source (git-checkout (url url)
  299. (recursive? #t)))))))
  300. (_
  301. (raise
  302. (formatted-message
  303. (G_ "~a: invalid Git URL replacement specification")
  304. spec)))))
  305. replacement-specs))
  306. (define rewrite
  307. (package-input-rewriting/spec replacements))
  308. (lambda (obj)
  309. (if (package? obj)
  310. (rewrite obj)
  311. obj)))
  312. (define (package-dependents/spec top bottom)
  313. "Return the list of dependents of BOTTOM, a spec string, that are also
  314. dependencies of TOP, a package."
  315. (define-values (name version)
  316. (package-name->name+version bottom))
  317. (define dependent?
  318. (mlambda (p)
  319. (and (package? p)
  320. (or (and (string=? name (package-name p))
  321. (or (not version)
  322. (version-prefix? version (package-version p))))
  323. (match (bag-direct-inputs (package->bag p))
  324. (((labels dependencies . _) ...)
  325. (any dependent? dependencies)))))))
  326. (filter dependent? (package-closure (list top))))
  327. (define (package-toolchain-rewriting p bottom toolchain)
  328. "Return a procedure that, when passed a package that's either BOTTOM or one
  329. of its dependents up to P so, changes it so it is built with TOOLCHAIN.
  330. TOOLCHAIN must be an input list."
  331. (define rewriting-property
  332. (gensym " package-toolchain-rewriting"))
  333. (match (package-dependents/spec p bottom)
  334. (() ;P does not depend on BOTTOM
  335. identity)
  336. (set
  337. ;; SET is the list of packages "between" P and BOTTOM (included) whose
  338. ;; toolchain needs to be changed.
  339. (package-mapping (lambda (p)
  340. (if (or (assq rewriting-property
  341. (package-properties p))
  342. (not (memq p set)))
  343. p
  344. (let ((p (package-with-c-toolchain p toolchain)))
  345. (package/inherit p
  346. (properties `((,rewriting-property . #t)
  347. ,@(package-properties p)))))))
  348. (lambda (p)
  349. (or (assq rewriting-property (package-properties p))
  350. (not (memq p set))))
  351. #:deep? #t))))
  352. (define (transform-package-toolchain replacement-specs)
  353. "Return a procedure that, when passed a package, changes its toolchain or
  354. that of its dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is
  355. a list of strings like \"fftw=gcc-toolchain@10\" meaning that the package to
  356. the left of the equal sign must be built with the toolchain to the right of
  357. the equal sign."
  358. (define split-on-commas
  359. (cute string-tokenize <> (char-set-complement (char-set #\,))))
  360. (define (specification->input spec)
  361. (let ((package (specification->package spec)))
  362. (list (package-name package) package)))
  363. (define replacements
  364. (map (lambda (spec)
  365. (match (string-tokenize spec %not-equal)
  366. ((spec (= split-on-commas toolchain))
  367. (cons spec (map specification->input toolchain)))
  368. (_
  369. (raise
  370. (formatted-message
  371. (G_ "~a: invalid toolchain replacement specification")
  372. spec)))))
  373. replacement-specs))
  374. (lambda (obj)
  375. (if (package? obj)
  376. (or (any (match-lambda
  377. ((bottom . toolchain)
  378. ((package-toolchain-rewriting obj bottom toolchain) obj)))
  379. replacements)
  380. obj)
  381. obj)))
  382. (define tuning-compiler
  383. (mlambda (micro-architecture)
  384. "Return a compiler wrapper that passes '-march=MICRO-ARCHITECTURE' to the
  385. actual compiler."
  386. (define wrapper
  387. #~(begin
  388. (use-modules (ice-9 match))
  389. (define* (search-next command
  390. #:optional
  391. (path (string-split (getenv "PATH")
  392. #\:)))
  393. ;; Search the next COMMAND on PATH, a list of
  394. ;; directories representing the executable search path.
  395. (define this
  396. (stat (car (command-line))))
  397. (let loop ((path path))
  398. (match path
  399. (()
  400. (match command
  401. ("cc" (search-next "gcc"))
  402. (_ #f)))
  403. ((directory rest ...)
  404. (let* ((file (string-append
  405. directory "/" command))
  406. (st (stat file #f)))
  407. (if (and st (not (equal? this st)))
  408. file
  409. (loop rest)))))))
  410. (match (command-line)
  411. ((command arguments ...)
  412. (match (search-next (basename command))
  413. (#f (exit 127))
  414. (next
  415. (apply execl next
  416. (append (cons next arguments)
  417. (list (string-append "-march="
  418. #$micro-architecture))))))))))
  419. (define program
  420. (program-file (string-append "tuning-compiler-wrapper-" micro-architecture)
  421. wrapper))
  422. (computed-file (string-append "tuning-compiler-" micro-architecture)
  423. (with-imported-modules '((guix build utils))
  424. #~(begin
  425. (use-modules (guix build utils))
  426. (define bin (string-append #$output "/bin"))
  427. (mkdir-p bin)
  428. (for-each (lambda (program)
  429. (symlink #$program
  430. (string-append bin "/" program)))
  431. '("cc" "gcc" "clang" "g++" "c++" "clang++")))))))
  432. (define (build-system-with-tuning-compiler bs micro-architecture)
  433. "Return a variant of BS, a build system, that ensures that the compiler that
  434. BS uses (usually an implicit input) can generate code for MICRO-ARCHITECTURE,
  435. which names a specific CPU of the target architecture--e.g., when targeting
  436. 86_64 MICRO-ARCHITECTURE might be \"skylake\". If it does, return a build
  437. system that builds code for MICRO-ARCHITECTURE; otherwise raise an error."
  438. (define %not-hyphen
  439. (char-set-complement (char-set #\-)))
  440. (define lower
  441. (build-system-lower bs))
  442. (define (lower* . args)
  443. ;; The list of CPU names supported by the '-march' option of C/C++
  444. ;; compilers is specific to each compiler and version thereof. Rather
  445. ;; than pass '-march=MICRO-ARCHITECTURE' as is to the compiler, possibly
  446. ;; leading to an obscure build error, check whether the compiler is known
  447. ;; to support MICRO-ARCHITECTURE. If not, bail out.
  448. (let* ((lowered (apply lower args))
  449. (architecture (match (string-tokenize (bag-system lowered)
  450. %not-hyphen)
  451. ((arch _ ...) arch)))
  452. (compiler (any (match-lambda
  453. ((label (? package? p) . _)
  454. (and (assoc-ref (package-properties p)
  455. 'compiler-cpu-architectures)
  456. p))
  457. (_ #f))
  458. (bag-build-inputs lowered))))
  459. (unless compiler
  460. (raise (formatted-message
  461. (G_ "failed to determine which compiler is used"))))
  462. (let ((lst (assoc-ref (package-properties compiler)
  463. 'compiler-cpu-architectures)))
  464. (unless lst
  465. (raise (formatted-message
  466. (G_ "failed to determine whether ~a supports ~a")
  467. (package-full-name compiler)
  468. micro-architecture)))
  469. (unless (member micro-architecture
  470. (or (assoc-ref lst architecture) '()))
  471. (raise (formatted-message
  472. (G_ "compiler ~a does not support micro-architecture ~a")
  473. (package-full-name compiler)
  474. micro-architecture))))
  475. (bag
  476. (inherit lowered)
  477. (build-inputs
  478. ;; Arrange so that the compiler wrapper comes first in $PATH.
  479. `(("tuning-compiler" ,(tuning-compiler micro-architecture))
  480. ,@(bag-build-inputs lowered))))))
  481. (build-system
  482. (inherit bs)
  483. (lower lower*)))
  484. (define (tuned-package p micro-architecture)
  485. "Return package P tuned for MICRO-ARCHITECTURE."
  486. (package
  487. (inherit p)
  488. (build-system
  489. (build-system-with-tuning-compiler (package-build-system p)
  490. micro-architecture))
  491. (arguments
  492. ;; The machine building this package may or may not be able to run code
  493. ;; for MICRO-ARCHITECTURE. Because of that, skip tests; they are run for
  494. ;; the "baseline" variant anyway.
  495. (substitute-keyword-arguments (package-arguments p)
  496. ((#:tests? _ #f) #f)))
  497. (properties
  498. `((cpu-tuning . ,micro-architecture)
  499. ;; Remove the 'tunable?' property so that 'package-tuning' does not
  500. ;; call 'tuned-package' again on this one.
  501. ,@(alist-delete 'tunable? (package-properties p))))))
  502. (define (tunable-package? package)
  503. "Return true if package PACKAGE is \"tunable\"--i.e., if tuning it for the
  504. host CPU is worthwhile."
  505. (assq 'tunable? (package-properties package)))
  506. (define package-tuning
  507. (mlambda (micro-architecture)
  508. "Return a procedure that maps the given package to its counterpart tuned
  509. for MICRO-ARCHITECTURE, a string suitable for GCC's '-march'."
  510. (define rewriting-property
  511. (gensym " package-tuning"))
  512. (package-mapping (lambda (p)
  513. (cond ((assq rewriting-property (package-properties p))
  514. p)
  515. ((assq 'tunable? (package-properties p))
  516. (info (G_ "tuning ~a for CPU ~a~%")
  517. (package-full-name p) micro-architecture)
  518. (package/inherit p
  519. (replacement (tuned-package p micro-architecture))
  520. (properties `((,rewriting-property . #t)
  521. ,@(package-properties p)))))
  522. (else
  523. p)))
  524. (lambda (p)
  525. (assq rewriting-property (package-properties p)))
  526. #:deep? #t)))
  527. (define (transform-package-tuning micro-architectures)
  528. "Return a procedure that, when "
  529. (match micro-architectures
  530. ((micro-architecture _ ...)
  531. (let ((rewrite (package-tuning micro-architecture)))
  532. (lambda (obj)
  533. (if (package? obj)
  534. (rewrite obj)
  535. obj))))))
  536. (define (transform-package-with-debug-info specs)
  537. "Return a procedure that, when passed a package, set its 'replacement' field
  538. to the same package but with #:strip-binaries? #f in its 'arguments' field."
  539. (define (non-stripped p)
  540. (package
  541. (inherit p)
  542. (arguments
  543. (substitute-keyword-arguments (package-arguments p)
  544. ((#:strip-binaries? _ #f) #f)))))
  545. (define (package-with-debug-info p)
  546. (if (member "debug" (package-outputs p))
  547. p
  548. (let loop ((p p))
  549. (match (package-replacement p)
  550. (#f
  551. (package
  552. (inherit p)
  553. (replacement (non-stripped p))))
  554. (next
  555. (package
  556. (inherit p)
  557. (replacement (loop next))))))))
  558. (define rewrite
  559. (package-input-rewriting/spec (map (lambda (spec)
  560. (cons spec package-with-debug-info))
  561. specs)))
  562. (lambda (obj)
  563. (if (package? obj)
  564. (rewrite obj)
  565. obj)))
  566. (define (transform-package-tests specs)
  567. "Return a procedure that, when passed a package, sets #:tests? #f in its
  568. 'arguments' field."
  569. (define (package-without-tests p)
  570. (package/inherit p
  571. (arguments
  572. (substitute-keyword-arguments (package-arguments p)
  573. ((#:tests? _ #f) #f)))))
  574. (define rewrite
  575. (package-input-rewriting/spec (map (lambda (spec)
  576. (cons spec package-without-tests))
  577. specs)))
  578. (lambda (obj)
  579. (if (package? obj)
  580. (rewrite obj)
  581. obj)))
  582. (define (patched-source name source patches)
  583. "Return a file-like object with the given NAME that applies PATCHES to
  584. SOURCE. SOURCE must itself be a file-like object of any type, including
  585. <git-checkout>, <local-file>, etc."
  586. (define patch
  587. (module-ref (resolve-interface '(gnu packages base)) 'patch))
  588. (computed-file name
  589. (with-imported-modules '((guix build utils))
  590. #~(begin
  591. (use-modules (guix build utils))
  592. (setenv "PATH" #+(file-append patch "/bin"))
  593. ;; XXX: Assume SOURCE is a directory. This is true in
  594. ;; most practical cases, where it's a <git-checkout>.
  595. (copy-recursively #+source #$output)
  596. (chdir #$output)
  597. (for-each (lambda (patch)
  598. (invoke "patch" "-p1" "--batch"
  599. "-i" patch))
  600. '(#+@patches))))))
  601. (define (transform-package-patches specs)
  602. "Return a procedure that, when passed a package, returns a package with
  603. additional patches."
  604. (define (package-with-extra-patches p patches)
  605. (let ((patches (map (lambda (file)
  606. (local-file file))
  607. patches)))
  608. (if (origin? (package-source p))
  609. (package/inherit p
  610. (source (origin
  611. (inherit (package-source p))
  612. (patches (append patches
  613. (origin-patches (package-source p)))))))
  614. (package/inherit p
  615. (source (patched-source (string-append (package-full-name p "-")
  616. "-source")
  617. (package-source p) patches))))))
  618. (define (coalesce-alist alist)
  619. ;; Coalesce multiple occurrences of the same key in ALIST.
  620. (let loop ((alist alist)
  621. (keys '())
  622. (mapping vlist-null))
  623. (match alist
  624. (()
  625. (map (lambda (key)
  626. (cons key (vhash-fold* cons '() key mapping)))
  627. (delete-duplicates (reverse keys))))
  628. (((key . value) . rest)
  629. (loop rest
  630. (cons key keys)
  631. (vhash-cons key value mapping))))))
  632. (define patches
  633. ;; Spec/patch alist.
  634. (coalesce-alist
  635. (map (lambda (spec)
  636. (match (string-tokenize spec %not-equal)
  637. ((spec patch)
  638. (cons spec (canonicalize-path patch)))
  639. (_
  640. (raise (formatted-message
  641. (G_ "~a: invalid package patch specification")
  642. spec)))))
  643. specs)))
  644. (define rewrite
  645. (package-input-rewriting/spec
  646. (map (match-lambda
  647. ((spec . patches)
  648. (cons spec (cut package-with-extra-patches <> patches))))
  649. patches)))
  650. (lambda (obj)
  651. (if (package? obj)
  652. (rewrite obj)
  653. obj)))
  654. (define (transform-package-latest specs)
  655. "Return a procedure that rewrites package graphs such that those in SPECS
  656. are replaced by their latest upstream version."
  657. (define (package-with-latest-upstream p)
  658. (let ((source (package-latest-release p)))
  659. (cond ((not source)
  660. (warning
  661. (G_ "could not determine latest upstream release of '~a'~%")
  662. (package-name p))
  663. p)
  664. ((string=? (upstream-source-version source)
  665. (package-version p))
  666. p)
  667. (else
  668. (unless (pair? (upstream-source-signature-urls source))
  669. (warning (G_ "cannot authenticate source of '~a', version ~a~%")
  670. (package-name p)
  671. (upstream-source-version source)))
  672. ;; TODO: Take 'upstream-source-input-changes' into account.
  673. (package
  674. (inherit p)
  675. (version (upstream-source-version source))
  676. (source source))))))
  677. (define rewrite
  678. (package-input-rewriting/spec
  679. (map (lambda (spec)
  680. (cons spec package-with-latest-upstream))
  681. specs)))
  682. (lambda (obj)
  683. (if (package? obj)
  684. (rewrite obj)
  685. obj)))
  686. (define %transformations
  687. ;; Transformations that can be applied to things to build. The car is the
  688. ;; key used in the option alist, and the cdr is the transformation
  689. ;; procedure; it is called with two arguments: the store, and a list of
  690. ;; things to build.
  691. `((with-source . ,transform-package-source)
  692. (with-input . ,transform-package-inputs)
  693. (with-graft . ,transform-package-inputs/graft)
  694. (with-branch . ,transform-package-source-branch)
  695. (with-commit . ,transform-package-source-commit)
  696. (with-git-url . ,transform-package-source-git-url)
  697. (with-c-toolchain . ,transform-package-toolchain)
  698. (tune . ,transform-package-tuning)
  699. (with-debug-info . ,transform-package-with-debug-info)
  700. (without-tests . ,transform-package-tests)
  701. (with-patch . ,transform-package-patches)
  702. (with-latest . ,transform-package-latest)))
  703. (define (transformation-procedure key)
  704. "Return the transformation procedure associated with KEY, a symbol such as
  705. 'with-source', or #f if there is none."
  706. (any (match-lambda
  707. ((k . proc)
  708. (and (eq? k key) proc)))
  709. %transformations))
  710. (define (transformation-option-key? key)
  711. "Return true if KEY is an option key (as returned while parsing options with
  712. %TRANSFORMATION-OPTIONS) corresponding to a package transformation option.
  713. For example, (transformation-option-key? 'with-input) => #t."
  714. (->bool (transformation-procedure key)))
  715. ;;;
  716. ;;; Command-line handling.
  717. ;;;
  718. (define %transformation-options
  719. ;; The command-line interface to the above transformations.
  720. (let ((parser (lambda (symbol)
  721. (lambda (opt name arg result . rest)
  722. (apply values
  723. (alist-cons symbol arg result)
  724. rest)))))
  725. (list (option '("with-source") #t #f
  726. (parser 'with-source))
  727. (option '("with-input") #t #f
  728. (parser 'with-input))
  729. (option '("with-graft") #t #f
  730. (parser 'with-graft))
  731. (option '("with-branch") #t #f
  732. (parser 'with-branch))
  733. (option '("with-commit") #t #f
  734. (parser 'with-commit))
  735. (option '("with-git-url") #t #f
  736. (parser 'with-git-url))
  737. (option '("with-c-toolchain") #t #f
  738. (parser 'with-c-toolchain))
  739. (option '("tune") #f #t
  740. (lambda (opt name arg result . rest)
  741. (define micro-architecture
  742. (match arg
  743. ((or #f "native")
  744. (unless (string=? (or (assoc-ref result 'system)
  745. (%current-system))
  746. %system)
  747. (leave (G_ "\
  748. building for ~a instead of ~a, so tuning cannot be guessed~%")
  749. (assoc-ref result 'system) %system))
  750. (cpu->gcc-architecture (current-cpu)))
  751. ("generic" #f)
  752. (_ arg)))
  753. (apply values
  754. (if micro-architecture
  755. (alist-cons 'tune micro-architecture
  756. result)
  757. (alist-delete 'tune result))
  758. rest)))
  759. (option '("with-debug-info") #t #f
  760. (parser 'with-debug-info))
  761. (option '("without-tests") #t #f
  762. (parser 'without-tests))
  763. (option '("with-patch") #t #f
  764. (parser 'with-patch))
  765. (option '("with-latest") #t #f
  766. (parser 'with-latest))
  767. (option '("help-transform") #f #f
  768. (lambda _
  769. (format #t
  770. (G_ "Available package transformation options:~%"))
  771. (show-transformation-options-help/detailed)
  772. (newline)
  773. (exit 0))))))
  774. (define (show-transformation-options-help/detailed)
  775. (display (G_ "
  776. --with-source=[PACKAGE=]SOURCE
  777. use SOURCE when building the corresponding package"))
  778. (display (G_ "
  779. --with-input=PACKAGE=REPLACEMENT
  780. replace dependency PACKAGE by REPLACEMENT"))
  781. (display (G_ "
  782. --with-graft=PACKAGE=REPLACEMENT
  783. graft REPLACEMENT on packages that refer to PACKAGE"))
  784. (display (G_ "
  785. --with-branch=PACKAGE=BRANCH
  786. build PACKAGE from the latest commit of BRANCH"))
  787. (display (G_ "
  788. --with-commit=PACKAGE=COMMIT
  789. build PACKAGE from COMMIT"))
  790. (display (G_ "
  791. --with-git-url=PACKAGE=URL
  792. build PACKAGE from the repository at URL"))
  793. (display (G_ "
  794. --with-patch=PACKAGE=FILE
  795. add FILE to the list of patches of PACKAGE"))
  796. (display (G_ "
  797. --with-latest=PACKAGE
  798. use the latest upstream release of PACKAGE"))
  799. (display (G_ "
  800. --with-c-toolchain=PACKAGE=TOOLCHAIN
  801. build PACKAGE and its dependents with TOOLCHAIN"))
  802. (display (G_ "
  803. --with-debug-info=PACKAGE
  804. build PACKAGE and preserve its debug info"))
  805. (display (G_ "
  806. --without-tests=PACKAGE
  807. build PACKAGE without running its tests")))
  808. (define (show-transformation-options-help)
  809. "Show basic help for package transformation options."
  810. (display (G_ "
  811. --help-transform list package transformation options not shown here")))
  812. (define (options->transformation opts)
  813. "Return a procedure that, when passed an object to build (package,
  814. derivation, etc.), applies the transformations specified by OPTS and returns
  815. the resulting objects. OPTS must be a list of symbol/string pairs such as:
  816. ((with-branch . \"guile-gcrypt=master\")
  817. (without-tests . \"libgcrypt\"))
  818. Each symbol names a transformation and the corresponding string is an argument
  819. to that transformation."
  820. (define applicable
  821. ;; List of applicable transformations as symbol/procedure pairs in the
  822. ;; order in which they appear on the command line.
  823. (filter-map (match-lambda
  824. ((key . value)
  825. (match (transformation-procedure key)
  826. (#f
  827. #f)
  828. (transform
  829. ;; XXX: We used to pass TRANSFORM a list of several
  830. ;; arguments, but we now pass only one, assuming that
  831. ;; transform composes well.
  832. (list key value (transform (list value)))))))
  833. (reverse opts)))
  834. (define (package-with-transformation-properties p)
  835. (package/inherit p
  836. (properties `((transformations
  837. . ,(map (match-lambda
  838. ((key value _)
  839. (cons key value)))
  840. applicable))
  841. ,@(package-properties p)))))
  842. (lambda (obj)
  843. (define (tagged-object new)
  844. (if (and (not (eq? obj new))
  845. (package? new) (not (null? applicable)))
  846. (package-with-transformation-properties new)
  847. new))
  848. (tagged-object
  849. (fold (match-lambda*
  850. (((name value transform) obj)
  851. (let ((new (transform obj)))
  852. (when (eq? new obj)
  853. (warning (G_ "transformation '~a' had no effect on ~a~%")
  854. name
  855. (if (package? obj)
  856. (package-full-name obj)
  857. obj)))
  858. new)))
  859. obj
  860. applicable))))
  861. (define (package-transformations package)
  862. "Return the transformations applied to PACKAGE according to its properties."
  863. (match (assq-ref (package-properties package) 'transformations)
  864. (#f '())
  865. (transformations transformations)))
  866. (define (manifest-entry-with-transformations entry)
  867. "Return ENTRY with an additional 'transformations' property if it's not
  868. already there."
  869. (let ((properties (manifest-entry-properties entry)))
  870. (if (assq 'transformations properties)
  871. entry
  872. (let ((item (manifest-entry-item entry)))
  873. (manifest-entry
  874. (inherit entry)
  875. (properties
  876. (match (and (package? item)
  877. (package-transformations item))
  878. ((or #f '())
  879. properties)
  880. (transformations
  881. `((transformations . ,transformations)
  882. ,@properties)))))))))