guix build: Move transformation options to (guix transformations).

* guix/transformations.scm: New file.
* tests/scripts-build.scm: Rename to...
* tests/transformations.scm: ... this.
* Makefile.am (MODULES): Add 'guix/transformations.scm'.
(SCM_TESTS): Adjust to rename.
* guix/scripts/build.scm (numeric-extension?)
(tarball-base-name, <downloaded-file>, download-to-store*)
(compile-downloaded-file, package-with-source)
(transform-package-source, evaluate-replacement-specs)
(transform-package-inputs, transform-package-inputs/graft)
(%not-equal, package-git-url, evaluate-git-replacement-specs)
(transform-package-source-branch, transform-package-source-commit)
(transform-package-source-git-url, package-dependents/spec)
(package-toolchain-rewriting, transform-package-toolchain)
(transform-package-with-debug-info, transform-package-tests)
(%transformations, transformation-procedure, %transformation-options)
(show-transformation-options-help, options->transformation)
(package-transformations): Move to (guix transformations).
* guix/scripts/environment.scm: Adjust accordingly.
* guix/scripts/graph.scm: Likewise.
* guix/scripts/install.scm: Likewise.
* guix/scripts/pack.scm: Likewise.
* guix/scripts/package.scm: Likewise.
* guix/scripts/upgrade.scm: Likewise.
* po/guix/POTFILES.in: Add 'guix/transformations.scm'.

1 files changed, 1 insertions, 552 deletions

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