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'. --- Makefile.am | 3 +- 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 + guix/transformations.scm | 610 +++++++++++++++++++++++++++++++++++++++++++ po/guix/POTFILES.in | 1 + tests/scripts-build.scm | 380 --------------------------- tests/transformations.scm | 380 +++++++++++++++++++++++++++ 12 files changed, 1002 insertions(+), 935 deletions(-) create mode 100644 guix/transformations.scm delete mode 100644 tests/scripts-build.scm create mode 100644 tests/transformations.scm diff --git a/Makefile.am b/Makefile.am index f3eb681a2b..e7053ee4f4 100644 --- a/Makefile.am +++ b/Makefile.am @@ -105,6 +105,7 @@ MODULES = \ guix/derivations.scm \ guix/grafts.scm \ guix/repl.scm \ + guix/transformations.scm \ guix/inferior.scm \ guix/describe.scm \ guix/quirks.scm \ @@ -456,7 +457,6 @@ SCM_TESTS = \ tests/pypi.scm \ tests/records.scm \ tests/scripts.scm \ - tests/scripts-build.scm \ tests/search-paths.scm \ tests/services.scm \ tests/services/linux.scm \ @@ -473,6 +473,7 @@ SCM_TESTS = \ tests/syscalls.scm \ tests/system.scm \ tests/texlive.scm \ + tests/transformations.scm \ tests/ui.scm \ tests/union.scm \ tests/upstream.scm \ 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) diff --git a/guix/transformations.scm b/guix/transformations.scm new file mode 100644 index 0000000000..126a9a69d3 --- /dev/null +++ b/guix/transformations.scm @@ -0,0 +1,610 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix transformations) + #:use-module (guix i18n) + #:use-module (guix store) + #:use-module (guix packages) + #: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) + #: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-37) + #:use-module (ice-9 match) + #:export (options->transformation + manifest-entry-with-transformations + + show-transformation-options-help + %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 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)) + (_ + (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)) + + +;;; +;;; 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 '("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 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))))))))) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index b877fac9df..5a164b77e3 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -80,6 +80,7 @@ guix/gexp.scm guix/gnu-maintenance.scm guix/scripts/container.scm guix/scripts/container/exec.scm +guix/transformations.scm guix/upstream.scm guix/ui.scm guix/status.scm diff --git a/tests/scripts-build.scm b/tests/scripts-build.scm deleted file mode 100644 index d56e02b452..0000000000 --- a/tests/scripts-build.scm +++ /dev/null @@ -1,380 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017, 2019, 2020 Ludovic Courtès -;;; -;;; 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 . - -(define-module (test-scripts-build) - #:use-module (guix tests) - #:use-module (guix store) - #:use-module ((guix gexp) #:select (lower-object)) - #:use-module (guix derivations) - #:use-module (guix packages) - #:use-module (guix git-download) - #:use-module (guix build-system) - #:use-module (guix build-system gnu) - #:use-module (guix scripts build) - #:use-module (guix ui) - #:use-module (guix utils) - #:use-module (guix git) - #:use-module (gnu packages) - #:use-module (gnu packages base) - #:use-module (gnu packages busybox) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-64)) - - -(test-begin "scripts-build") - -(test-assert "options->transformation, no transformations" - (let ((p (dummy-package "foo")) - (t (options->transformation '()))) - (eq? (t p) p))) - -(test-assert "options->transformation, with-source" - ;; Our pseudo-package is called 'guix.scm' so the 'guix.scm' source should - ;; be applicable. - (let* ((p (dummy-package "guix.scm")) - (s (search-path %load-path "guix.scm")) - (t (options->transformation `((with-source . ,s))))) - (with-store store - (let* ((new (t p)) - (source (run-with-store store - (lower-object (package-source new))))) - (and (not (eq? new p)) - (string=? source - (add-to-store store "guix.scm" #t - "sha256" s))))))) - -(test-assert "options->transformation, with-source, replacement" - ;; Same, but this time the original package has a 'replacement' field. We - ;; expect that replacement to be set to #f in the new package. - (let* ((p (dummy-package "guix.scm" (replacement coreutils))) - (s (search-path %load-path "guix.scm")) - (t (options->transformation `((with-source . ,s))))) - (let ((new (t p))) - (and (not (eq? new p)) - (not (package-replacement new)))))) - -(test-assert "options->transformation, with-source, with version" - ;; Our pseudo-package is called 'guix.scm' so the 'guix.scm-2.0' source - ;; should be applicable, and its version should be extracted. - (let ((p (dummy-package "foo")) - (s (search-path %load-path "guix.scm"))) - (call-with-temporary-directory - (lambda (directory) - (let* ((f (string-append directory "/foo-42.0.tar.gz")) - (t (options->transformation `((with-source . ,f))))) - (copy-file s f) - (with-store store - (let* ((new (t p)) - (source (run-with-store store - (lower-object (package-source new))))) - (and (not (eq? new p)) - (string=? (package-name new) (package-name p)) - (string=? (package-version new) "42.0") - (string=? source - (add-to-store store (basename f) #t - "sha256" f)))))))))) - -(test-assert "options->transformation, with-source, no matches" - ;; When a transformation in not applicable, a warning must be raised. - (let* ((p (dummy-package "foobar")) - (s (search-path %load-path "guix.scm")) - (t (options->transformation `((with-source . ,s))))) - (let* ((port (open-output-string)) - (new (parameterize ((guix-warning-port port)) - (t p)))) - (and (eq? new p) - (string-contains (get-output-string port) - "had no effect"))))) - -(test-assert "options->transformation, with-source, PKG=URI" - (let* ((p (dummy-package "foo")) - (s (search-path %load-path "guix.scm")) - (f (string-append "foo=" s)) - (t (options->transformation `((with-source . ,f))))) - (with-store store - (let* ((new (t p)) - (source (run-with-store store - (lower-object (package-source new))))) - (and (not (eq? new p)) - (string=? (package-name new) (package-name p)) - (string=? (package-version new) - (package-version p)) - (string=? source - (add-to-store store (basename s) #t - "sha256" s))))))) - -(test-assert "options->transformation, with-source, PKG@VER=URI" - (let* ((p (dummy-package "foo")) - (s (search-path %load-path "guix.scm")) - (f (string-append "foo@42.0=" s)) - (t (options->transformation `((with-source . ,f))))) - (with-store store - (let* ((new (t p)) - (source (run-with-store store - (lower-object (package-source new))))) - (and (not (eq? new p)) - (string=? (package-name new) (package-name p)) - (string=? (package-version new) "42.0") - (string=? source - (add-to-store store (basename s) #t - "sha256" s))))))) - -(test-assert "options->transformation, with-input" - (let* ((p (dummy-package "guix.scm" - (inputs `(("foo" ,(specification->package "coreutils")) - ("bar" ,(specification->package "grep")) - ("baz" ,(dummy-package "chbouib" - (native-inputs `(("x" ,grep))))))))) - (t (options->transformation '((with-input . "coreutils=busybox") - (with-input . "grep=findutils"))))) - (let ((new (t p))) - (and (not (eq? new p)) - (match (package-inputs new) - ((("foo" dep1) ("bar" dep2) ("baz" dep3)) - (and (string=? (package-full-name dep1) - (package-full-name busybox)) - (string=? (package-full-name dep2) - (package-full-name findutils)) - (string=? (package-name dep3) "chbouib") - (match (package-native-inputs dep3) - ((("x" dep)) - (string=? (package-full-name dep) - (package-full-name findutils))))))))))) - -(test-assert "options->transformation, with-graft" - (let* ((p (dummy-package "guix.scm" - (inputs `(("foo" ,grep) - ("bar" ,(dummy-package "chbouib" - (native-inputs `(("x" ,grep))))))))) - (t (options->transformation '((with-graft . "grep=findutils"))))) - (let ((new (t p))) - (and (not (eq? new p)) - (match (package-inputs new) - ((("foo" dep1) ("bar" dep2)) - (and (string=? (package-full-name dep1) - (package-full-name grep)) - (string=? (package-full-name (package-replacement dep1)) - (package-full-name findutils)) - (string=? (package-name dep2) "chbouib") - (match (package-native-inputs dep2) - ((("x" dep)) - (with-store store - (string=? (derivation-file-name - (package-derivation store findutils)) - (derivation-file-name - (package-derivation store dep))))))))))))) - -(test-equal "options->transformation, with-branch" - (git-checkout (url "https://example.org") - (branch "devel") - (recursive? #t)) - (let* ((p (dummy-package "guix.scm" - (inputs `(("foo" ,grep) - ("bar" ,(dummy-package "chbouib" - (source (origin - (method git-fetch) - (uri (git-reference - (url "https://example.org") - (commit "cabba9e"))) - (sha256 #f))))))))) - (t (options->transformation '((with-branch . "chbouib=devel"))))) - (let ((new (t p))) - (and (not (eq? new p)) - (match (package-inputs new) - ((("foo" dep1) ("bar" dep2)) - (and (string=? (package-full-name dep1) - (package-full-name grep)) - (string=? (package-name dep2) "chbouib") - (package-source dep2)))))))) - -(test-equal "options->transformation, with-commit" - (git-checkout (url "https://example.org") - (commit "abcdef") - (recursive? #t)) - (let* ((p (dummy-package "guix.scm" - (inputs `(("foo" ,grep) - ("bar" ,(dummy-package "chbouib" - (source (origin - (method git-fetch) - (uri (git-reference - (url "https://example.org") - (commit "cabba9e"))) - (sha256 #f))))))))) - (t (options->transformation '((with-commit . "chbouib=abcdef"))))) - (let ((new (t p))) - (and (not (eq? new p)) - (match (package-inputs new) - ((("foo" dep1) ("bar" dep2)) - (and (string=? (package-full-name dep1) - (package-full-name grep)) - (string=? (package-name dep2) "chbouib") - (package-source dep2)))))))) - -(test-equal "options->transformation, with-git-url" - (let ((source (git-checkout (url "https://example.org") - (recursive? #t)))) - (list source source)) - (let* ((p (dummy-package "guix.scm" - (inputs `(("foo" ,grep) - ("bar" ,(dummy-package "chbouib" - (native-inputs `(("x" ,grep))))))))) - (t (options->transformation '((with-git-url . "grep=https://example.org"))))) - (let ((new (t p))) - (and (not (eq? new p)) - (match (package-inputs new) - ((("foo" dep1) ("bar" dep2)) - (and (string=? (package-full-name dep1) - (package-full-name grep)) - (string=? (package-name dep2) "chbouib") - (match (package-native-inputs dep2) - ((("x" dep3)) - (map package-source (list dep1 dep3))))))))))) - -(test-equal "options->transformation, with-git-url + with-branch" - ;; Combine the two options and make sure the 'with-branch' transformation - ;; comes after the 'with-git-url' transformation. - (let ((source (git-checkout (url "https://example.org") - (branch "BRANCH") - (recursive? #t)))) - (list source source)) - (let* ((p (dummy-package "guix.scm" - (inputs `(("foo" ,grep) - ("bar" ,(dummy-package "chbouib" - (native-inputs `(("x" ,grep))))))))) - (t (options->transformation - (reverse '((with-git-url - . "grep=https://example.org") - (with-branch . "grep=BRANCH")))))) - (let ((new (t p))) - (and (not (eq? new p)) - (match (package-inputs new) - ((("foo" dep1) ("bar" dep2)) - (and (string=? (package-name dep1) "grep") - (string=? (package-name dep2) "chbouib") - (match (package-native-inputs dep2) - ((("x" dep3)) - (map package-source (list dep1 dep3))))))))))) - -(define* (depends-on-toolchain? p #:optional (toolchain "gcc-toolchain")) - "Return true if P depends on TOOLCHAIN instead of the default tool chain." - (define toolchain-packages - '("gcc" "binutils" "glibc" "ld-wrapper")) - - (define (package-name* obj) - (and (package? obj) (package-name obj))) - - (match (bag-build-inputs (package->bag p)) - (((_ (= package-name* packages) . _) ...) - (and (not (any (cut member <> packages) toolchain-packages)) - (member toolchain packages))))) - -(test-assert "options->transformation, with-c-toolchain" - (let* ((dep0 (dummy-package "chbouib" - (build-system gnu-build-system) - (native-inputs `(("y" ,grep))))) - (dep1 (dummy-package "stuff" - (native-inputs `(("x" ,dep0))))) - (p (dummy-package "thingie" - (build-system gnu-build-system) - (inputs `(("foo" ,grep) - ("bar" ,dep1))))) - (t (options->transformation - '((with-c-toolchain . "chbouib=gcc-toolchain"))))) - ;; Here we check that the transformation applies to DEP0 and all its - ;; dependents: DEP0 must use GCC-TOOLCHAIN, DEP1 must use GCC-TOOLCHAIN - ;; and the DEP0 that uses GCC-TOOLCHAIN, and so on. - (let ((new (t p))) - (and (depends-on-toolchain? new "gcc-toolchain") - (match (bag-build-inputs (package->bag new)) - ((("foo" dep0) ("bar" dep1) _ ...) - (and (depends-on-toolchain? dep1 "gcc-toolchain") - (not (depends-on-toolchain? dep0 "gcc-toolchain")) - (string=? (package-full-name dep0) - (package-full-name grep)) - (match (bag-build-inputs (package->bag dep1)) - ((("x" dep) _ ...) - (and (depends-on-toolchain? dep "gcc-toolchain") - (match (bag-build-inputs (package->bag dep)) - ((("y" dep) _ ...) ;this one is unchanged - (eq? dep grep))))))))))))) - -(test-equal "options->transformation, with-c-toolchain twice" - (package-full-name grep) - (let* ((dep0 (dummy-package "chbouib")) - (dep1 (dummy-package "stuff")) - (p (dummy-package "thingie" - (build-system gnu-build-system) - (inputs `(("foo" ,dep0) - ("bar" ,dep1) - ("baz" ,grep))))) - (t (options->transformation - '((with-c-toolchain . "chbouib=clang-toolchain") - (with-c-toolchain . "stuff=clang-toolchain"))))) - (let ((new (t p))) - (and (depends-on-toolchain? new "clang-toolchain") - (match (bag-build-inputs (package->bag new)) - ((("foo" dep0) ("bar" dep1) ("baz" dep2) _ ...) - (and (depends-on-toolchain? dep0 "clang-toolchain") - (depends-on-toolchain? dep1 "clang-toolchain") - (not (depends-on-toolchain? dep2 "clang-toolchain")) - (package-full-name dep2)))))))) - -(test-assert "options->transformation, with-c-toolchain, no effect" - (let ((p (dummy-package "thingie")) - (t (options->transformation - '((with-c-toolchain . "does-not-exist=gcc-toolchain"))))) - ;; When it has no effect, '--with-c-toolchain' returns P. - (eq? (t p) p))) - -(test-equal "options->transformation, with-debug-info" - '(#:strip-binaries? #f) - (let* ((dep (dummy-package "chbouib")) - (p (dummy-package "thingie" - (build-system gnu-build-system) - (inputs `(("foo" ,dep) - ("bar" ,grep))))) - (t (options->transformation - '((with-debug-info . "chbouib"))))) - (let ((new (t p))) - (match (package-inputs new) - ((("foo" dep0) ("bar" dep1)) - (and (string=? (package-full-name dep1) - (package-full-name grep)) - (package-arguments (package-replacement dep0)))))))) - -(test-assert "options->transformation, without-tests" - (let* ((dep (dummy-package "dep")) - (p (dummy-package "foo" - (inputs `(("dep" ,dep))))) - (t (options->transformation '((without-tests . "dep") - (without-tests . "tar"))))) - (let ((new (t p))) - (match (bag-direct-inputs (package->bag new)) - ((("dep" dep) ("tar" tar) _ ...) - ;; TODO: Check whether TAR has #:tests? #f when transformations - ;; apply to implicit inputs. - (equal? (package-arguments dep) - '(#:tests? #f))))))) - -(test-end) - -;;; Local Variables: -;;; eval: (put 'dummy-package 'scheme-indent-function 1) -;;; End: diff --git a/tests/transformations.scm b/tests/transformations.scm new file mode 100644 index 0000000000..07ed8b1234 --- /dev/null +++ b/tests/transformations.scm @@ -0,0 +1,380 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016, 2017, 2019, 2020 Ludovic Courtès +;;; +;;; 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 . + +(define-module (test-transformations) + #:use-module (guix tests) + #:use-module (guix store) + #:use-module ((guix gexp) #:select (lower-object)) + #:use-module (guix derivations) + #:use-module (guix packages) + #:use-module (guix git-download) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (guix transformations) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix git) + #:use-module (gnu packages) + #:use-module (gnu packages base) + #:use-module (gnu packages busybox) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-64)) + + +(test-begin "transformations") + +(test-assert "options->transformation, no transformations" + (let ((p (dummy-package "foo")) + (t (options->transformation '()))) + (eq? (t p) p))) + +(test-assert "options->transformation, with-source" + ;; Our pseudo-package is called 'guix.scm' so the 'guix.scm' source should + ;; be applicable. + (let* ((p (dummy-package "guix.scm")) + (s (search-path %load-path "guix.scm")) + (t (options->transformation `((with-source . ,s))))) + (with-store store + (let* ((new (t p)) + (source (run-with-store store + (lower-object (package-source new))))) + (and (not (eq? new p)) + (string=? source + (add-to-store store "guix.scm" #t + "sha256" s))))))) + +(test-assert "options->transformation, with-source, replacement" + ;; Same, but this time the original package has a 'replacement' field. We + ;; expect that replacement to be set to #f in the new package. + (let* ((p (dummy-package "guix.scm" (replacement coreutils))) + (s (search-path %load-path "guix.scm")) + (t (options->transformation `((with-source . ,s))))) + (let ((new (t p))) + (and (not (eq? new p)) + (not (package-replacement new)))))) + +(test-assert "options->transformation, with-source, with version" + ;; Our pseudo-package is called 'guix.scm' so the 'guix.scm-2.0' source + ;; should be applicable, and its version should be extracted. + (let ((p (dummy-package "foo")) + (s (search-path %load-path "guix.scm"))) + (call-with-temporary-directory + (lambda (directory) + (let* ((f (string-append directory "/foo-42.0.tar.gz")) + (t (options->transformation `((with-source . ,f))))) + (copy-file s f) + (with-store store + (let* ((new (t p)) + (source (run-with-store store + (lower-object (package-source new))))) + (and (not (eq? new p)) + (string=? (package-name new) (package-name p)) + (string=? (package-version new) "42.0") + (string=? source + (add-to-store store (basename f) #t + "sha256" f)))))))))) + +(test-assert "options->transformation, with-source, no matches" + ;; When a transformation in not applicable, a warning must be raised. + (let* ((p (dummy-package "foobar")) + (s (search-path %load-path "guix.scm")) + (t (options->transformation `((with-source . ,s))))) + (let* ((port (open-output-string)) + (new (parameterize ((guix-warning-port port)) + (t p)))) + (and (eq? new p) + (string-contains (get-output-string port) + "had no effect"))))) + +(test-assert "options->transformation, with-source, PKG=URI" + (let* ((p (dummy-package "foo")) + (s (search-path %load-path "guix.scm")) + (f (string-append "foo=" s)) + (t (options->transformation `((with-source . ,f))))) + (with-store store + (let* ((new (t p)) + (source (run-with-store store + (lower-object (package-source new))))) + (and (not (eq? new p)) + (string=? (package-name new) (package-name p)) + (string=? (package-version new) + (package-version p)) + (string=? source + (add-to-store store (basename s) #t + "sha256" s))))))) + +(test-assert "options->transformation, with-source, PKG@VER=URI" + (let* ((p (dummy-package "foo")) + (s (search-path %load-path "guix.scm")) + (f (string-append "foo@42.0=" s)) + (t (options->transformation `((with-source . ,f))))) + (with-store store + (let* ((new (t p)) + (source (run-with-store store + (lower-object (package-source new))))) + (and (not (eq? new p)) + (string=? (package-name new) (package-name p)) + (string=? (package-version new) "42.0") + (string=? source + (add-to-store store (basename s) #t + "sha256" s))))))) + +(test-assert "options->transformation, with-input" + (let* ((p (dummy-package "guix.scm" + (inputs `(("foo" ,(specification->package "coreutils")) + ("bar" ,(specification->package "grep")) + ("baz" ,(dummy-package "chbouib" + (native-inputs `(("x" ,grep))))))))) + (t (options->transformation '((with-input . "coreutils=busybox") + (with-input . "grep=findutils"))))) + (let ((new (t p))) + (and (not (eq? new p)) + (match (package-inputs new) + ((("foo" dep1) ("bar" dep2) ("baz" dep3)) + (and (string=? (package-full-name dep1) + (package-full-name busybox)) + (string=? (package-full-name dep2) + (package-full-name findutils)) + (string=? (package-name dep3) "chbouib") + (match (package-native-inputs dep3) + ((("x" dep)) + (string=? (package-full-name dep) + (package-full-name findutils))))))))))) + +(test-assert "options->transformation, with-graft" + (let* ((p (dummy-package "guix.scm" + (inputs `(("foo" ,grep) + ("bar" ,(dummy-package "chbouib" + (native-inputs `(("x" ,grep))))))))) + (t (options->transformation '((with-graft . "grep=findutils"))))) + (let ((new (t p))) + (and (not (eq? new p)) + (match (package-inputs new) + ((("foo" dep1) ("bar" dep2)) + (and (string=? (package-full-name dep1) + (package-full-name grep)) + (string=? (package-full-name (package-replacement dep1)) + (package-full-name findutils)) + (string=? (package-name dep2) "chbouib") + (match (package-native-inputs dep2) + ((("x" dep)) + (with-store store + (string=? (derivation-file-name + (package-derivation store findutils)) + (derivation-file-name + (package-derivation store dep))))))))))))) + +(test-equal "options->transformation, with-branch" + (git-checkout (url "https://example.org") + (branch "devel") + (recursive? #t)) + (let* ((p (dummy-package "guix.scm" + (inputs `(("foo" ,grep) + ("bar" ,(dummy-package "chbouib" + (source (origin + (method git-fetch) + (uri (git-reference + (url "https://example.org") + (commit "cabba9e"))) + (sha256 #f))))))))) + (t (options->transformation '((with-branch . "chbouib=devel"))))) + (let ((new (t p))) + (and (not (eq? new p)) + (match (package-inputs new) + ((("foo" dep1) ("bar" dep2)) + (and (string=? (package-full-name dep1) + (package-full-name grep)) + (string=? (package-name dep2) "chbouib") + (package-source dep2)))))))) + +(test-equal "options->transformation, with-commit" + (git-checkout (url "https://example.org") + (commit "abcdef") + (recursive? #t)) + (let* ((p (dummy-package "guix.scm" + (inputs `(("foo" ,grep) + ("bar" ,(dummy-package "chbouib" + (source (origin + (method git-fetch) + (uri (git-reference + (url "https://example.org") + (commit "cabba9e"))) + (sha256 #f))))))))) + (t (options->transformation '((with-commit . "chbouib=abcdef"))))) + (let ((new (t p))) + (and (not (eq? new p)) + (match (package-inputs new) + ((("foo" dep1) ("bar" dep2)) + (and (string=? (package-full-name dep1) + (package-full-name grep)) + (string=? (package-name dep2) "chbouib") + (package-source dep2)))))))) + +(test-equal "options->transformation, with-git-url" + (let ((source (git-checkout (url "https://example.org") + (recursive? #t)))) + (list source source)) + (let* ((p (dummy-package "guix.scm" + (inputs `(("foo" ,grep) + ("bar" ,(dummy-package "chbouib" + (native-inputs `(("x" ,grep))))))))) + (t (options->transformation '((with-git-url . "grep=https://example.org"))))) + (let ((new (t p))) + (and (not (eq? new p)) + (match (package-inputs new) + ((("foo" dep1) ("bar" dep2)) + (and (string=? (package-full-name dep1) + (package-full-name grep)) + (string=? (package-name dep2) "chbouib") + (match (package-native-inputs dep2) + ((("x" dep3)) + (map package-source (list dep1 dep3))))))))))) + +(test-equal "options->transformation, with-git-url + with-branch" + ;; Combine the two options and make sure the 'with-branch' transformation + ;; comes after the 'with-git-url' transformation. + (let ((source (git-checkout (url "https://example.org") + (branch "BRANCH") + (recursive? #t)))) + (list source source)) + (let* ((p (dummy-package "guix.scm" + (inputs `(("foo" ,grep) + ("bar" ,(dummy-package "chbouib" + (native-inputs `(("x" ,grep))))))))) + (t (options->transformation + (reverse '((with-git-url + . "grep=https://example.org") + (with-branch . "grep=BRANCH")))))) + (let ((new (t p))) + (and (not (eq? new p)) + (match (package-inputs new) + ((("foo" dep1) ("bar" dep2)) + (and (string=? (package-name dep1) "grep") + (string=? (package-name dep2) "chbouib") + (match (package-native-inputs dep2) + ((("x" dep3)) + (map package-source (list dep1 dep3))))))))))) + +(define* (depends-on-toolchain? p #:optional (toolchain "gcc-toolchain")) + "Return true if P depends on TOOLCHAIN instead of the default tool chain." + (define toolchain-packages + '("gcc" "binutils" "glibc" "ld-wrapper")) + + (define (package-name* obj) + (and (package? obj) (package-name obj))) + + (match (bag-build-inputs (package->bag p)) + (((_ (= package-name* packages) . _) ...) + (and (not (any (cut member <> packages) toolchain-packages)) + (member toolchain packages))))) + +(test-assert "options->transformation, with-c-toolchain" + (let* ((dep0 (dummy-package "chbouib" + (build-system gnu-build-system) + (native-inputs `(("y" ,grep))))) + (dep1 (dummy-package "stuff" + (native-inputs `(("x" ,dep0))))) + (p (dummy-package "thingie" + (build-system gnu-build-system) + (inputs `(("foo" ,grep) + ("bar" ,dep1))))) + (t (options->transformation + '((with-c-toolchain . "chbouib=gcc-toolchain"))))) + ;; Here we check that the transformation applies to DEP0 and all its + ;; dependents: DEP0 must use GCC-TOOLCHAIN, DEP1 must use GCC-TOOLCHAIN + ;; and the DEP0 that uses GCC-TOOLCHAIN, and so on. + (let ((new (t p))) + (and (depends-on-toolchain? new "gcc-toolchain") + (match (bag-build-inputs (package->bag new)) + ((("foo" dep0) ("bar" dep1) _ ...) + (and (depends-on-toolchain? dep1 "gcc-toolchain") + (not (depends-on-toolchain? dep0 "gcc-toolchain")) + (string=? (package-full-name dep0) + (package-full-name grep)) + (match (bag-build-inputs (package->bag dep1)) + ((("x" dep) _ ...) + (and (depends-on-toolchain? dep "gcc-toolchain") + (match (bag-build-inputs (package->bag dep)) + ((("y" dep) _ ...) ;this one is unchanged + (eq? dep grep))))))))))))) + +(test-equal "options->transformation, with-c-toolchain twice" + (package-full-name grep) + (let* ((dep0 (dummy-package "chbouib")) + (dep1 (dummy-package "stuff")) + (p (dummy-package "thingie" + (build-system gnu-build-system) + (inputs `(("foo" ,dep0) + ("bar" ,dep1) + ("baz" ,grep))))) + (t (options->transformation + '((with-c-toolchain . "chbouib=clang-toolchain") + (with-c-toolchain . "stuff=clang-toolchain"))))) + (let ((new (t p))) + (and (depends-on-toolchain? new "clang-toolchain") + (match (bag-build-inputs (package->bag new)) + ((("foo" dep0) ("bar" dep1) ("baz" dep2) _ ...) + (and (depends-on-toolchain? dep0 "clang-toolchain") + (depends-on-toolchain? dep1 "clang-toolchain") + (not (depends-on-toolchain? dep2 "clang-toolchain")) + (package-full-name dep2)))))))) + +(test-assert "options->transformation, with-c-toolchain, no effect" + (let ((p (dummy-package "thingie")) + (t (options->transformation + '((with-c-toolchain . "does-not-exist=gcc-toolchain"))))) + ;; When it has no effect, '--with-c-toolchain' returns P. + (eq? (t p) p))) + +(test-equal "options->transformation, with-debug-info" + '(#:strip-binaries? #f) + (let* ((dep (dummy-package "chbouib")) + (p (dummy-package "thingie" + (build-system gnu-build-system) + (inputs `(("foo" ,dep) + ("bar" ,grep))))) + (t (options->transformation + '((with-debug-info . "chbouib"))))) + (let ((new (t p))) + (match (package-inputs new) + ((("foo" dep0) ("bar" dep1)) + (and (string=? (package-full-name dep1) + (package-full-name grep)) + (package-arguments (package-replacement dep0)))))))) + +(test-assert "options->transformation, without-tests" + (let* ((dep (dummy-package "dep")) + (p (dummy-package "foo" + (inputs `(("dep" ,dep))))) + (t (options->transformation '((without-tests . "dep") + (without-tests . "tar"))))) + (let ((new (t p))) + (match (bag-direct-inputs (package->bag new)) + ((("dep" dep) ("tar" tar) _ ...) + ;; TODO: Check whether TAR has #:tests? #f when transformations + ;; apply to implicit inputs. + (equal? (package-arguments dep) + '(#:tests? #f))))))) + +(test-end) + +;;; Local Variables: +;;; eval: (put 'dummy-package 'scheme-indent-function 1) +;;; End: -- cgit v1.2.3