summaryrefslogtreecommitdiff
path: root/guix/scripts
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2020-10-29 18:30:07 +0100
committerLudovic Courtès <ludo@gnu.org>2020-10-31 23:16:43 +0100
commitf68b3ba12dc7532dddde7dc63afb81a8492c661e (patch)
tree79d63569d34c05a677ede5461877730f2b1d422a /guix/scripts
parent1ae33664a67d9588ee730a2a1d46c29e20a92bcb (diff)
guix build: Move transformation options to (guix transformations).
* guix/transformations.scm: New file. * tests/scripts-build.scm: Rename to... * tests/transformations.scm: ... this. * Makefile.am (MODULES): Add 'guix/transformations.scm'. (SCM_TESTS): Adjust to rename. * guix/scripts/build.scm (numeric-extension?) (tarball-base-name, <downloaded-file>, download-to-store*) (compile-downloaded-file, package-with-source) (transform-package-source, evaluate-replacement-specs) (transform-package-inputs, transform-package-inputs/graft) (%not-equal, package-git-url, evaluate-git-replacement-specs) (transform-package-source-branch, transform-package-source-commit) (transform-package-source-git-url, package-dependents/spec) (package-toolchain-rewriting, transform-package-toolchain) (transform-package-with-debug-info, transform-package-tests) (%transformations, transformation-procedure, %transformation-options) (show-transformation-options-help, options->transformation) (package-transformations): Move to (guix transformations). * guix/scripts/environment.scm: Adjust accordingly. * guix/scripts/graph.scm: Likewise. * guix/scripts/install.scm: Likewise. * guix/scripts/pack.scm: Likewise. * guix/scripts/package.scm: Likewise. * guix/scripts/upgrade.scm: Likewise. * po/guix/POTFILES.in: Add 'guix/transformations.scm'.
Diffstat (limited to 'guix/scripts')
-rw-r--r--guix/scripts/build.scm553
-rw-r--r--guix/scripts/environment.scm1
-rw-r--r--guix/scripts/graph.scm5
-rw-r--r--guix/scripts/install.scm1
-rw-r--r--guix/scripts/pack.scm1
-rw-r--r--guix/scripts/package.scm1
-rw-r--r--guix/scripts/upgrade.scm1
7 files changed, 9 insertions, 554 deletions
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 4b86047587..e9de97c881 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -31,11 +31,6 @@
#:use-module (guix utils)
- ;; Use the procedure that destructures "NAME-VERSION" forms.
- #:use-module ((guix build utils)
- #:select ((package-name->name+version
- . hyphen-package-name->name+version)))
-
#:use-module (guix monads)
#:use-module (guix gexp)
#:use-module (guix profiles)
@@ -52,21 +47,15 @@
#:use-module (srfi srfi-35)
#:use-module (srfi srfi-37)
#:use-module (gnu packages)
- #:autoload (guix download) (download-to-store)
- #:autoload (guix git-download) (git-reference? git-reference-url)
- #:autoload (guix git) (git-checkout git-checkout? git-checkout-url)
#:use-module ((guix status) #:select (with-status-verbosity))
#:use-module ((guix progress) #:select (current-terminal-columns))
#:use-module ((guix build syscalls) #:select (terminal-columns))
+ #:use-module (guix transformations)
#:export (%standard-build-options
set-build-options-from-command-line
set-build-options-from-command-line*
show-build-options-help
- %transformation-options
- options->transformation
- manifest-entry-with-transformations
-
guix-build
register-root
register-root*))
@@ -151,546 +140,6 @@ found. Return #f if no build log was found."
(define register-root*
(store-lift register-root))
-(define (numeric-extension? file-name)
- "Return true if FILE-NAME ends with digits."
- (string-every char-set:hex-digit (file-extension file-name)))
-
-(define (tarball-base-name file-name)
- "Return the \"base\" of FILE-NAME, removing '.tar.gz' or similar
-extensions."
- ;; TODO: Factorize.
- (cond ((not (file-extension file-name))
- file-name)
- ((numeric-extension? file-name)
- file-name)
- ((string=? (file-extension file-name) "tar")
- (file-sans-extension file-name))
- ((file-extension file-name)
- =>
- (match-lambda
- ("scm" file-name)
- (else (tarball-base-name (file-sans-extension file-name)))))
- (else
- file-name)))
-
-
-;; Files to be downloaded.
-(define-record-type <downloaded-file>
- (downloaded-file uri recursive?)
- downloaded-file?
- (uri downloaded-file-uri)
- (recursive? downloaded-file-recursive?))
-
-(define download-to-store*
- (store-lift download-to-store))
-
-(define-gexp-compiler (compile-downloaded-file (file <downloaded-file>)
- system target)
- "Download FILE and return the result as a store item."
- (match file
- (($ <downloaded-file> uri recursive?)
- (download-to-store* uri #:recursive? recursive?))))
-
-(define* (package-with-source p uri #:optional version)
- "Return a package based on P but with its source taken from URI. Extract
-the new package's version number from URI."
- (let ((base (tarball-base-name (basename uri))))
- (let-values (((_ version*)
- (hyphen-package-name->name+version base)))
- (package (inherit p)
- (version (or version version*
- (package-version p)))
-
- ;; Use #:recursive? #t to allow for directories.
- (source (downloaded-file uri #t))))))
-
-
-;;;
-;;; Transformations.
-;;;
-
-(define (transform-package-source sources)
- "Return a transformation procedure that replaces package sources with the
-matching URIs given in SOURCES."
- (define new-sources
- (map (lambda (uri)
- (match (string-index uri #\=)
- (#f
- ;; Determine the package name and version from URI.
- (call-with-values
- (lambda ()
- (hyphen-package-name->name+version
- (tarball-base-name (basename uri))))
- (lambda (name version)
- (list name version uri))))
- (index
- ;; What's before INDEX is a "PKG@VER" or "PKG" spec.
- (call-with-values
- (lambda ()
- (package-name->name+version (string-take uri index)))
- (lambda (name version)
- (list name version
- (string-drop uri (+ 1 index))))))))
- sources))
-
- (lambda (obj)
- (let loop ((sources new-sources)
- (result '()))
- (match obj
- ((? package? p)
- (match (assoc-ref sources (package-name p))
- ((version source)
- (package-with-source p source version))
- (#f
- p)))
- (_
- obj)))))
-
-(define (evaluate-replacement-specs specs proc)
- "Parse SPECS, a list of strings like \"guile=guile@2.1\" and return a list
-of package spec/procedure pairs as expected by 'package-input-rewriting/spec'.
-PROC is called with the package to be replaced and its replacement according
-to SPECS. Raise an error if an element of SPECS uses invalid syntax, or if a
-package it refers to could not be found."
- (define not-equal
- (char-set-complement (char-set #\=)))
-
- (map (lambda (spec)
- (match (string-tokenize spec not-equal)
- ((spec new)
- (cons spec
- (let ((new (specification->package new)))
- (lambda (old)
- (proc old new)))))
- (x
- (leave (G_ "invalid replacement specification: ~s~%") spec))))
- specs))
-
-(define (transform-package-inputs replacement-specs)
- "Return a procedure that, when passed a package, replaces its direct
-dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
-strings like \"guile=guile@2.1\" meaning that, any dependency on a package
-called \"guile\" must be replaced with a dependency on a version 2.1 of
-\"guile\"."
- (let* ((replacements (evaluate-replacement-specs replacement-specs
- (lambda (old new)
- new)))
- (rewrite (package-input-rewriting/spec replacements)))
- (lambda (obj)
- (if (package? obj)
- (rewrite obj)
- obj))))
-
-(define (transform-package-inputs/graft replacement-specs)
- "Return a procedure that, when passed a package, replaces its direct
-dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
-strings like \"gnutls=gnutls@3.5.4\" meaning that packages are built using the
-current 'gnutls' package, after which version 3.5.4 is grafted onto them."
- (define (set-replacement old new)
- (package (inherit old) (replacement new)))
-
- (let* ((replacements (evaluate-replacement-specs replacement-specs
- set-replacement))
- (rewrite (package-input-rewriting/spec replacements)))
- (lambda (obj)
- (if (package? obj)
- (rewrite obj)
- obj))))
-
-(define %not-equal
- (char-set-complement (char-set #\=)))
-
-(define (package-git-url package)
- "Return the URL of the Git repository for package, or raise an error if
-the source of PACKAGE is not fetched from a Git repository."
- (let ((source (package-source package)))
- (cond ((and (origin? source)
- (git-reference? (origin-uri source)))
- (git-reference-url (origin-uri source)))
- ((git-checkout? source)
- (git-checkout-url source))
- (else
- (leave (G_ "the source of ~a is not a Git reference~%")
- (package-full-name package))))))
-
-(define (evaluate-git-replacement-specs specs proc)
- "Parse SPECS, a list of strings like \"guile=stable-2.2\", and return a list
-of package pairs, where (PROC PACKAGE URL BRANCH-OR-COMMIT) returns the
-replacement package. Raise an error if an element of SPECS uses invalid
-syntax, or if a package it refers to could not be found."
- (map (lambda (spec)
- (match (string-tokenize spec %not-equal)
- ((spec branch-or-commit)
- (define (replace old)
- (let* ((source (package-source old))
- (url (package-git-url old)))
- (proc old url branch-or-commit)))
-
- (cons spec replace))
- (x
- (leave (G_ "invalid replacement specification: ~s~%") spec))))
- specs))
-
-(define (transform-package-source-branch replacement-specs)
- "Return a procedure that, when passed a package, replaces its direct
-dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
-strings like \"guile-next=stable-3.0\" meaning that packages are built using
-'guile-next' from the latest commit on its 'stable-3.0' branch."
- (define (replace old url branch)
- (package
- (inherit old)
- (version (string-append "git." (string-map (match-lambda
- (#\/ #\-)
- (chr chr))
- branch)))
- (source (git-checkout (url url) (branch branch)
- (recursive? #t)))))
-
- (let* ((replacements (evaluate-git-replacement-specs replacement-specs
- replace))
- (rewrite (package-input-rewriting/spec replacements)))
- (lambda (obj)
- (if (package? obj)
- (rewrite obj)
- obj))))
-
-(define (transform-package-source-commit replacement-specs)
- "Return a procedure that, when passed a package, replaces its direct
-dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
-strings like \"guile-next=cabba9e\" meaning that packages are built using
-'guile-next' from commit 'cabba9e'."
- (define (replace old url commit)
- (package
- (inherit old)
- (version (if (and (> (string-length commit) 1)
- (string-prefix? "v" commit)
- (char-set-contains? char-set:digit
- (string-ref commit 1)))
- (string-drop commit 1) ;looks like a tag like "v1.0"
- (string-append "git."
- (if (< (string-length commit) 7)
- commit
- (string-take commit 7)))))
- (source (git-checkout (url url) (commit commit)
- (recursive? #t)))))
-
- (let* ((replacements (evaluate-git-replacement-specs replacement-specs
- replace))
- (rewrite (package-input-rewriting/spec replacements)))
- (lambda (obj)
- (if (package? obj)
- (rewrite obj)
- obj))))
-
-(define (transform-package-source-git-url replacement-specs)
- "Return a procedure that, when passed a package, replaces its dependencies
-according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of strings like
-\"guile-json=https://gitthing.com/…\" meaning that packages are built using
-a checkout of the Git repository at the given URL."
- (define replacements
- (map (lambda (spec)
- (match (string-tokenize spec %not-equal)
- ((spec url)
- (cons spec
- (lambda (old)
- (package
- (inherit old)
- (source (git-checkout (url url)
- (recursive? #t)))))))
- (_
- (leave (G_ "~a: invalid Git URL replacement specification~%")
- spec))))
- replacement-specs))
-
- (define rewrite
- (package-input-rewriting/spec replacements))
-
- (lambda (obj)
- (if (package? obj)
- (rewrite obj)
- obj)))
-
-(define (package-dependents/spec top bottom)
- "Return the list of dependents of BOTTOM, a spec string, that are also
-dependencies of TOP, a package."
- (define-values (name version)
- (package-name->name+version bottom))
-
- (define dependent?
- (mlambda (p)
- (and (package? p)
- (or (and (string=? name (package-name p))
- (or (not version)
- (version-prefix? version (package-version p))))
- (match (bag-direct-inputs (package->bag p))
- (((labels dependencies . _) ...)
- (any dependent? dependencies)))))))
-
- (filter dependent? (package-closure (list top))))
-
-(define (package-toolchain-rewriting p bottom toolchain)
- "Return a procedure that, when passed a package that's either BOTTOM or one
-of its dependents up to P so, changes it so it is built with TOOLCHAIN.
-TOOLCHAIN must be an input list."
- (define rewriting-property
- (gensym " package-toolchain-rewriting"))
-
- (match (package-dependents/spec p bottom)
- (() ;P does not depend on BOTTOM
- identity)
- (set
- ;; SET is the list of packages "between" P and BOTTOM (included) whose
- ;; toolchain needs to be changed.
- (package-mapping (lambda (p)
- (if (or (assq rewriting-property
- (package-properties p))
- (not (memq p set)))
- p
- (let ((p (package-with-c-toolchain p toolchain)))
- (package/inherit p
- (properties `((,rewriting-property . #t)
- ,@(package-properties p)))))))
- (lambda (p)
- (or (assq rewriting-property (package-properties p))
- (not (memq p set))))
- #:deep? #t))))
-
-(define (transform-package-toolchain replacement-specs)
- "Return a procedure that, when passed a package, changes its toolchain or
-that of its dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is
-a list of strings like \"fftw=gcc-toolchain@10\" meaning that the package to
-the left of the equal sign must be built with the toolchain to the right of
-the equal sign."
- (define split-on-commas
- (cute string-tokenize <> (char-set-complement (char-set #\,))))
-
- (define (specification->input spec)
- (let ((package (specification->package spec)))
- (list (package-name package) package)))
-
- (define replacements
- (map (lambda (spec)
- (match (string-tokenize spec %not-equal)
- ((spec (= split-on-commas toolchain))
- (cons spec (map specification->input toolchain)))
- (_
- (leave (G_ "~a: invalid toolchain replacement specification~%")
- spec))))
- replacement-specs))
-
- (lambda (obj)
- (if (package? obj)
- (or (any (match-lambda
- ((bottom . toolchain)
- ((package-toolchain-rewriting obj bottom toolchain) obj)))
- replacements)
- obj)
- obj)))
-
-(define (transform-package-with-debug-info specs)
- "Return a procedure that, when passed a package, set its 'replacement' field
-to the same package but with #:strip-binaries? #f in its 'arguments' field."
- (define (non-stripped p)
- (package
- (inherit p)
- (arguments
- (substitute-keyword-arguments (package-arguments p)
- ((#:strip-binaries? _ #f) #f)))))
-
- (define (package-with-debug-info p)
- (if (member "debug" (package-outputs p))
- p
- (let loop ((p p))
- (match (package-replacement p)
- (#f
- (package
- (inherit p)
- (replacement (non-stripped p))))
- (next
- (package
- (inherit p)
- (replacement (loop next))))))))
-
- (define rewrite
- (package-input-rewriting/spec (map (lambda (spec)
- (cons spec package-with-debug-info))
- specs)))
-
- (lambda (obj)
- (if (package? obj)
- (rewrite obj)
- obj)))
-
-(define (transform-package-tests specs)
- "Return a procedure that, when passed a package, sets #:tests? #f in its
-'arguments' field."
- (define (package-without-tests p)
- (package/inherit p
- (arguments
- (substitute-keyword-arguments (package-arguments p)
- ((#:tests? _ #f) #f)))))
-
- (define rewrite
- (package-input-rewriting/spec (map (lambda (spec)
- (cons spec package-without-tests))
- specs)))
-
- (lambda (obj)
- (if (package? obj)
- (rewrite obj)
- obj)))
-
-(define %transformations
- ;; Transformations that can be applied to things to build. The car is the
- ;; key used in the option alist, and the cdr is the transformation
- ;; procedure; it is called with two arguments: the store, and a list of
- ;; things to build.
- `((with-source . ,transform-package-source)
- (with-input . ,transform-package-inputs)
- (with-graft . ,transform-package-inputs/graft)
- (with-branch . ,transform-package-source-branch)
- (with-commit . ,transform-package-source-commit)
- (with-git-url . ,transform-package-source-git-url)
- (with-c-toolchain . ,transform-package-toolchain)
- (with-debug-info . ,transform-package-with-debug-info)
- (without-tests . ,transform-package-tests)))
-
-(define (transformation-procedure key)
- "Return the transformation procedure associated with KEY, a symbol such as
-'with-source', or #f if there is none."
- (any (match-lambda
- ((k . proc)
- (and (eq? k key) proc)))
- %transformations))
-
-(define %transformation-options
- ;; The command-line interface to the above transformations.
- (let ((parser (lambda (symbol)
- (lambda (opt name arg result . rest)
- (apply values
- (alist-cons symbol arg result)
- rest)))))
- (list (option '("with-source") #t #f
- (parser 'with-source))
- (option '("with-input") #t #f
- (parser 'with-input))
- (option '("with-graft") #t #f
- (parser 'with-graft))
- (option '("with-branch") #t #f
- (parser 'with-branch))
- (option '("with-commit") #t #f
- (parser 'with-commit))
- (option '("with-git-url") #t #f
- (parser 'with-git-url))
- (option '("with-c-toolchain") #t #f
- (parser 'with-c-toolchain))
- (option '("with-debug-info") #t #f
- (parser 'with-debug-info))
- (option '("without-tests") #t #f
- (parser 'without-tests)))))
-
-(define (show-transformation-options-help)
- (display (G_ "
- --with-source=[PACKAGE=]SOURCE
- use SOURCE when building the corresponding package"))
- (display (G_ "
- --with-input=PACKAGE=REPLACEMENT
- replace dependency PACKAGE by REPLACEMENT"))
- (display (G_ "
- --with-graft=PACKAGE=REPLACEMENT
- graft REPLACEMENT on packages that refer to PACKAGE"))
- (display (G_ "
- --with-branch=PACKAGE=BRANCH
- build PACKAGE from the latest commit of BRANCH"))
- (display (G_ "
- --with-commit=PACKAGE=COMMIT
- build PACKAGE from COMMIT"))
- (display (G_ "
- --with-git-url=PACKAGE=URL
- build PACKAGE from the repository at URL"))
- (display (G_ "
- --with-c-toolchain=PACKAGE=TOOLCHAIN
- build PACKAGE and its dependents with TOOLCHAIN"))
- (display (G_ "
- --with-debug-info=PACKAGE
- build PACKAGE and preserve its debug info"))
- (display (G_ "
- --without-tests=PACKAGE
- build PACKAGE without running its tests")))
-
-
-(define (options->transformation opts)
- "Return a procedure that, when passed an object to build (package,
-derivation, etc.), applies the transformations specified by OPTS."
- (define applicable
- ;; List of applicable transformations as symbol/procedure pairs in the
- ;; order in which they appear on the command line.
- (filter-map (match-lambda
- ((key . value)
- (match (transformation-procedure key)
- (#f
- #f)
- (transform
- ;; XXX: We used to pass TRANSFORM a list of several
- ;; arguments, but we now pass only one, assuming that
- ;; transform composes well.
- (list key value (transform (list value)))))))
- (reverse opts)))
-
- (define (package-with-transformation-properties p)
- (package/inherit p
- (properties `((transformations
- . ,(map (match-lambda
- ((key value _)
- (cons key value)))
- applicable))
- ,@(package-properties p)))))
-
- (lambda (obj)
- (define (tagged-object new)
- (if (and (not (eq? obj new))
- (package? new) (not (null? applicable)))
- (package-with-transformation-properties new)
- new))
-
- (tagged-object
- (fold (match-lambda*
- (((name value transform) obj)
- (let ((new (transform obj)))
- (when (eq? new obj)
- (warning (G_ "transformation '~a' had no effect on ~a~%")
- name
- (if (package? obj)
- (package-full-name obj)
- obj)))
- new)))
- obj
- applicable))))
-
-(define (package-transformations package)
- "Return the transformations applied to PACKAGE according to its properties."
- (match (assq-ref (package-properties package) 'transformations)
- (#f '())
- (transformations transformations)))
-
-(define (manifest-entry-with-transformations entry)
- "Return ENTRY with an additional 'transformations' property if it's not
-already there."
- (let ((properties (manifest-entry-properties entry)))
- (if (assq 'transformations properties)
- entry
- (let ((item (manifest-entry-item entry)))
- (manifest-entry
- (inherit entry)
- (properties
- (match (and (package? item)
- (package-transformations item))
- ((or #f '())
- properties)
- (transformations
- `((transformations . ,transformations)
- ,@properties)))))))))
-
;;;
;;; Standard command-line build options.
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 4db6c5d2d7..2328df98b8 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -32,6 +32,7 @@
#:use-module ((guix gexp) #:select (lower-object))
#:use-module (guix scripts)
#:use-module (guix scripts build)
+ #:use-module (guix transformations)
#:use-module (gnu build linux-container)
#:use-module (gnu build accounts)
#:use-module ((guix build syscalls) #:select (set-network-interface-up))
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index 6b2e60d7e2..6874904deb 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -34,10 +34,11 @@
#:use-module (guix sets)
#:use-module ((guix diagnostics)
#:select (location-file formatted-message))
- #:use-module ((guix scripts build)
+ #:use-module ((guix transformations)
#:select (options->transformation
- %standard-build-options
%transformation-options))
+ #:use-module ((guix scripts build)
+ #:select (%standard-build-options))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
diff --git a/guix/scripts/install.scm b/guix/scripts/install.scm
index 5aafe3bd6d..82f5875dd1 100644
--- a/guix/scripts/install.scm
+++ b/guix/scripts/install.scm
@@ -20,6 +20,7 @@
#:use-module (guix ui)
#:use-module (guix scripts package)
#:use-module (guix scripts build)
+ #:use-module (guix transformations)
#:use-module (guix scripts)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 9fe5a24aee..82c40b247c 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -43,6 +43,7 @@
#:use-module (guix search-paths)
#:use-module (guix build-system gnu)
#:use-module (guix scripts build)
+ #:use-module (guix transformations)
#:use-module ((guix self) #:select (make-config.scm))
#:use-module (gnu packages)
#:use-module (gnu packages bootstrap)
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 5599e26f5d..eb2e67a0de 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -41,6 +41,7 @@
#:use-module (guix config)
#:use-module (guix scripts)
#:use-module (guix scripts build)
+ #:use-module (guix transformations)
#:use-module (guix describe)
#:autoload (guix store roots) (gc-roots user-owned?)
#:use-module ((guix build utils)
diff --git a/guix/scripts/upgrade.scm b/guix/scripts/upgrade.scm
index c4527d56d9..1ee8937acf 100644
--- a/guix/scripts/upgrade.scm
+++ b/guix/scripts/upgrade.scm
@@ -21,6 +21,7 @@
#:use-module (guix ui)
#:use-module (guix scripts package)
#:use-module (guix scripts build)
+ #:use-module (guix transformations)
#:use-module (guix scripts)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)