123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989 |
- ;;; GNU Guix --- Functional package management for GNU
- ;;; Copyright © 2016-2022 Ludovic Courtès <ludo@gnu.org>
- ;;; Copyright © 2021 Marius Bakke <marius@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 config) #:select (%system))
- #:use-module (guix i18n)
- #:use-module (guix store)
- #:use-module (guix packages)
- #:use-module (guix build-system)
- #: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)
- #:autoload (guix upstream) (package-latest-release
- upstream-source-version
- upstream-source-signature-urls)
- #:autoload (guix cpu) (current-cpu cpu->gcc-architecture)
- #: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-34)
- #:use-module (srfi srfi-37)
- #:use-module (ice-9 match)
- #:use-module (ice-9 vlist)
- #:export (options->transformation
- manifest-entry-with-transformations
- tunable-package?
- tuned-package
- show-transformation-options-help
- transformation-option-key?
- %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))))))
- ;;;
- ;;; 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
- (raise (formatted-message
- (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
- (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
- 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))
- (_
- (raise
- (formatted-message (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 (commit->version-string commit)
- "Return a string suitable for use in the 'version' field of a package based
- on the given COMMIT."
- (cond ((and (> (string-length commit) 1)
- (string-prefix? "v" commit)
- (char-set-contains? char-set:digit
- (string-ref commit 1)))
- ;; Probably a tag like "v1.0" or a 'git describe' identifier.
- (string-drop commit 1))
- ((not (string-every char-set:hex-digit commit))
- ;; Pass through tags and 'git describe' style IDs directly.
- commit)
- (else
- (string-append "git."
- (if (< (string-length commit) 7)
- commit
- (string-take commit 7))))))
- (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 (commit->version-string commit))
- (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)))))))
- (_
- (raise
- (formatted-message
- (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)))
- (_
- (raise
- (formatted-message
- (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 tuning-compiler
- (mlambda (micro-architecture)
- "Return a compiler wrapper that passes '-march=MICRO-ARCHITECTURE' to the
- actual compiler."
- (define wrapper
- #~(begin
- (use-modules (ice-9 match))
- (define* (search-next command
- #:optional
- (path (string-split (getenv "PATH")
- #\:)))
- ;; Search the next COMMAND on PATH, a list of
- ;; directories representing the executable search path.
- (define this
- (stat (car (command-line))))
- (let loop ((path path))
- (match path
- (()
- (match command
- ("cc" (search-next "gcc"))
- (_ #f)))
- ((directory rest ...)
- (let* ((file (string-append
- directory "/" command))
- (st (stat file #f)))
- (if (and st (not (equal? this st)))
- file
- (loop rest)))))))
- (match (command-line)
- ((command arguments ...)
- (match (search-next (basename command))
- (#f (exit 127))
- (next
- (apply execl next
- (append (cons next arguments)
- (list (string-append "-march="
- #$micro-architecture))))))))))
- (define program
- (program-file (string-append "tuning-compiler-wrapper-" micro-architecture)
- wrapper))
- (computed-file (string-append "tuning-compiler-" micro-architecture)
- (with-imported-modules '((guix build utils))
- #~(begin
- (use-modules (guix build utils))
- (define bin (string-append #$output "/bin"))
- (mkdir-p bin)
- (for-each (lambda (program)
- (symlink #$program
- (string-append bin "/" program)))
- '("cc" "gcc" "clang" "g++" "c++" "clang++")))))))
- (define (build-system-with-tuning-compiler bs micro-architecture)
- "Return a variant of BS, a build system, that ensures that the compiler that
- BS uses (usually an implicit input) can generate code for MICRO-ARCHITECTURE,
- which names a specific CPU of the target architecture--e.g., when targeting
- 86_64 MICRO-ARCHITECTURE might be \"skylake\". If it does, return a build
- system that builds code for MICRO-ARCHITECTURE; otherwise raise an error."
- (define %not-hyphen
- (char-set-complement (char-set #\-)))
- (define lower
- (build-system-lower bs))
- (define (lower* . args)
- ;; The list of CPU names supported by the '-march' option of C/C++
- ;; compilers is specific to each compiler and version thereof. Rather
- ;; than pass '-march=MICRO-ARCHITECTURE' as is to the compiler, possibly
- ;; leading to an obscure build error, check whether the compiler is known
- ;; to support MICRO-ARCHITECTURE. If not, bail out.
- (let* ((lowered (apply lower args))
- (architecture (match (string-tokenize (bag-system lowered)
- %not-hyphen)
- ((arch _ ...) arch)))
- (compiler (any (match-lambda
- ((label (? package? p) . _)
- (and (assoc-ref (package-properties p)
- 'compiler-cpu-architectures)
- p))
- (_ #f))
- (bag-build-inputs lowered))))
- (unless compiler
- (raise (formatted-message
- (G_ "failed to determine which compiler is used"))))
- (let ((lst (assoc-ref (package-properties compiler)
- 'compiler-cpu-architectures)))
- (unless lst
- (raise (formatted-message
- (G_ "failed to determine whether ~a supports ~a")
- (package-full-name compiler)
- micro-architecture)))
- (unless (member micro-architecture
- (or (assoc-ref lst architecture) '()))
- (raise (formatted-message
- (G_ "compiler ~a does not support micro-architecture ~a")
- (package-full-name compiler)
- micro-architecture))))
- (bag
- (inherit lowered)
- (build-inputs
- ;; Arrange so that the compiler wrapper comes first in $PATH.
- `(("tuning-compiler" ,(tuning-compiler micro-architecture))
- ,@(bag-build-inputs lowered))))))
- (build-system
- (inherit bs)
- (lower lower*)))
- (define (tuned-package p micro-architecture)
- "Return package P tuned for MICRO-ARCHITECTURE."
- (package
- (inherit p)
- (build-system
- (build-system-with-tuning-compiler (package-build-system p)
- micro-architecture))
- (arguments
- ;; The machine building this package may or may not be able to run code
- ;; for MICRO-ARCHITECTURE. Because of that, skip tests; they are run for
- ;; the "baseline" variant anyway.
- (substitute-keyword-arguments (package-arguments p)
- ((#:tests? _ #f) #f)))
- (properties
- `((cpu-tuning . ,micro-architecture)
- ;; Remove the 'tunable?' property so that 'package-tuning' does not
- ;; call 'tuned-package' again on this one.
- ,@(alist-delete 'tunable? (package-properties p))))))
- (define (tunable-package? package)
- "Return true if package PACKAGE is \"tunable\"--i.e., if tuning it for the
- host CPU is worthwhile."
- (assq 'tunable? (package-properties package)))
- (define package-tuning
- (mlambda (micro-architecture)
- "Return a procedure that maps the given package to its counterpart tuned
- for MICRO-ARCHITECTURE, a string suitable for GCC's '-march'."
- (define rewriting-property
- (gensym " package-tuning"))
- (package-mapping (lambda (p)
- (cond ((assq rewriting-property (package-properties p))
- p)
- ((assq 'tunable? (package-properties p))
- (info (G_ "tuning ~a for CPU ~a~%")
- (package-full-name p) micro-architecture)
- (package/inherit p
- (replacement (tuned-package p micro-architecture))
- (properties `((,rewriting-property . #t)
- ,@(package-properties p)))))
- (else
- p)))
- (lambda (p)
- (assq rewriting-property (package-properties p)))
- #:deep? #t)))
- (define (transform-package-tuning micro-architectures)
- "Return a procedure that, when "
- (match micro-architectures
- ((micro-architecture _ ...)
- (let ((rewrite (package-tuning micro-architecture)))
- (lambda (obj)
- (if (package? obj)
- (rewrite 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 (patched-source name source patches)
- "Return a file-like object with the given NAME that applies PATCHES to
- SOURCE. SOURCE must itself be a file-like object of any type, including
- <git-checkout>, <local-file>, etc."
- (define patch
- (module-ref (resolve-interface '(gnu packages base)) 'patch))
- (computed-file name
- (with-imported-modules '((guix build utils))
- #~(begin
- (use-modules (guix build utils))
- (setenv "PATH" #+(file-append patch "/bin"))
- ;; XXX: Assume SOURCE is a directory. This is true in
- ;; most practical cases, where it's a <git-checkout>.
- (copy-recursively #+source #$output)
- (chdir #$output)
- (for-each (lambda (patch)
- (invoke "patch" "-p1" "--batch"
- "-i" patch))
- '(#+@patches))))))
- (define (transform-package-patches specs)
- "Return a procedure that, when passed a package, returns a package with
- additional patches."
- (define (package-with-extra-patches p patches)
- (let ((patches (map (lambda (file)
- (local-file file))
- patches)))
- (if (origin? (package-source p))
- (package/inherit p
- (source (origin
- (inherit (package-source p))
- (patches (append patches
- (origin-patches (package-source p)))))))
- (package/inherit p
- (source (patched-source (string-append (package-full-name p "-")
- "-source")
- (package-source p) patches))))))
- (define (coalesce-alist alist)
- ;; Coalesce multiple occurrences of the same key in ALIST.
- (let loop ((alist alist)
- (keys '())
- (mapping vlist-null))
- (match alist
- (()
- (map (lambda (key)
- (cons key (vhash-fold* cons '() key mapping)))
- (delete-duplicates (reverse keys))))
- (((key . value) . rest)
- (loop rest
- (cons key keys)
- (vhash-cons key value mapping))))))
- (define patches
- ;; Spec/patch alist.
- (coalesce-alist
- (map (lambda (spec)
- (match (string-tokenize spec %not-equal)
- ((spec patch)
- (cons spec (canonicalize-path patch)))
- (_
- (raise (formatted-message
- (G_ "~a: invalid package patch specification")
- spec)))))
- specs)))
- (define rewrite
- (package-input-rewriting/spec
- (map (match-lambda
- ((spec . patches)
- (cons spec (cut package-with-extra-patches <> patches))))
- patches)))
- (lambda (obj)
- (if (package? obj)
- (rewrite obj)
- obj)))
- (define (transform-package-latest specs)
- "Return a procedure that rewrites package graphs such that those in SPECS
- are replaced by their latest upstream version."
- (define (package-with-latest-upstream p)
- (let ((source (package-latest-release p)))
- (cond ((not source)
- (warning
- (G_ "could not determine latest upstream release of '~a'~%")
- (package-name p))
- p)
- ((string=? (upstream-source-version source)
- (package-version p))
- p)
- (else
- (unless (pair? (upstream-source-signature-urls source))
- (warning (G_ "cannot authenticate source of '~a', version ~a~%")
- (package-name p)
- (upstream-source-version source)))
- ;; TODO: Take 'upstream-source-input-changes' into account.
- (package
- (inherit p)
- (version (upstream-source-version source))
- (source source))))))
- (define rewrite
- (package-input-rewriting/spec
- (map (lambda (spec)
- (cons spec package-with-latest-upstream))
- 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)
- (tune . ,transform-package-tuning)
- (with-debug-info . ,transform-package-with-debug-info)
- (without-tests . ,transform-package-tests)
- (with-patch . ,transform-package-patches)
- (with-latest . ,transform-package-latest)))
- (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-option-key? key)
- "Return true if KEY is an option key (as returned while parsing options with
- %TRANSFORMATION-OPTIONS) corresponding to a package transformation option.
- For example, (transformation-option-key? 'with-input) => #t."
- (->bool (transformation-procedure key)))
- ;;;
- ;;; 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 '("tune") #f #t
- (lambda (opt name arg result . rest)
- (define micro-architecture
- (match arg
- ((or #f "native")
- (unless (string=? (or (assoc-ref result 'system)
- (%current-system))
- %system)
- (leave (G_ "\
- building for ~a instead of ~a, so tuning cannot be guessed~%")
- (assoc-ref result 'system) %system))
- (cpu->gcc-architecture (current-cpu)))
- ("generic" #f)
- (_ arg)))
- (apply values
- (if micro-architecture
- (alist-cons 'tune micro-architecture
- result)
- (alist-delete 'tune result))
- rest)))
- (option '("with-debug-info") #t #f
- (parser 'with-debug-info))
- (option '("without-tests") #t #f
- (parser 'without-tests))
- (option '("with-patch") #t #f
- (parser 'with-patch))
- (option '("with-latest") #t #f
- (parser 'with-latest))
- (option '("help-transform") #f #f
- (lambda _
- (format #t
- (G_ "Available package transformation options:~%"))
- (show-transformation-options-help/detailed)
- (newline)
- (exit 0))))))
- (define (show-transformation-options-help/detailed)
- (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-patch=PACKAGE=FILE
- add FILE to the list of patches of PACKAGE"))
- (display (G_ "
- --with-latest=PACKAGE
- use the latest upstream release of PACKAGE"))
- (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 (show-transformation-options-help)
- "Show basic help for package transformation options."
- (display (G_ "
- --help-transform list package transformation options not shown here")))
- (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)))))))))
|