From f68b3ba12dc7532dddde7dc63afb81a8492c661e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 29 Oct 2020 18:30:07 +0100 Subject: 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, , 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'. --- guix/scripts/build.scm | 553 +------------------------------------------ guix/scripts/environment.scm | 1 + guix/scripts/graph.scm | 5 +- guix/scripts/install.scm | 1 + guix/scripts/pack.scm | 1 + guix/scripts/package.scm | 1 + guix/scripts/upgrade.scm | 1 + 7 files changed, 9 insertions(+), 554 deletions(-) (limited to 'guix/scripts') 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 @@ (define-module (guix scripts build) #: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 @@ (define-module (guix scripts build) #: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 @@ (define (register-root store paths root) (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 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 ) - system target) - "Download FILE and return the result as a store item." - (match 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 @@ (define-module (guix scripts environment) #: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 @@ (define-module (guix scripts graph) #: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 @@ (define-module (guix scripts install) #: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 @@ (define-module (guix scripts pack) #: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 @@ (define-module (guix scripts package) #: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 @@ (define-module (guix scripts upgrade) #: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) -- cgit v1.2.3