guix/transformations.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix transformations)
  20   #:use-module (guix i18n)
  21   #:use-module (guix store)
  22   #:use-module (guix packages)
  23   #:use-module (guix profiles)
  24   #:use-module (guix diagnostics)
  25   #:autoload   (guix download) (download-to-store)
  26   #:autoload   (guix git-download) (git-reference? git-reference-url)
  27   #:autoload   (guix git) (git-checkout git-checkout? git-checkout-url)
  28   #:autoload   (guix upstream) (package-latest-release*
  29                                 upstream-source-version
  30                                 upstream-source-signature-urls)
  31   #:use-module (guix utils)
  32   #:use-module (guix memoization)
  33   #:use-module (guix gexp)
  34
  35   ;; Use the procedure that destructures "NAME-VERSION" forms.
  36   #:use-module ((guix build utils)
  37                 #:select ((package-name->name+version
  38                            . hyphen-package-name->name+version)))
  39
  40   #:use-module (srfi srfi-1)
  41   #:use-module (srfi srfi-9)
  42   #:use-module (srfi srfi-11)
  43   #:use-module (srfi srfi-26)
  44   #:use-module (srfi srfi-34)
  45   #:use-module (srfi srfi-37)
  46   #:use-module (ice-9 match)
  47   #:use-module (ice-9 vlist)
  48   #:export (options->transformation
  49             manifest-entry-with-transformations
  50
  51             show-transformation-options-help
  52             %transformation-options))
  53
  54 ;;; Commentary:
  55 ;;;
  56 ;;; This module implements "package transformation options"---tools for
  57 ;;; package graph rewriting.  It contains the graph rewriting logic, but also
  58 ;;; the tip of its user interface: command-line option handling.
  59 ;;;
  60 ;;; Code:
  61
  62 (module-autoload! (current-module) '(gnu packages)
  63                   '(specification->package))
  64
  65 (define (numeric-extension? file-name)
  66   "Return true if FILE-NAME ends with digits."
  67   (string-every char-set:hex-digit (file-extension file-name)))
  68
  69 (define (tarball-base-name file-name)
  70   "Return the \"base\" of FILE-NAME, removing '.tar.gz' or similar
  71 extensions."
  72   ;; TODO: Factorize.
  73   (cond ((not (file-extension file-name))
  74          file-name)
  75         ((numeric-extension? file-name)
  76          file-name)
  77         ((string=? (file-extension file-name) "tar")
  78          (file-sans-extension file-name))
  79         ((file-extension file-name)
  80          =>
  81          (match-lambda
  82            ("scm" file-name)
  83            (_     (tarball-base-name (file-sans-extension file-name)))))
  84         (else
  85          file-name)))
  86
  87
  88 ;; Files to be downloaded.
  89 (define-record-type <downloaded-file>
  90   (downloaded-file uri recursive?)
  91   downloaded-file?
  92   (uri        downloaded-file-uri)
  93   (recursive? downloaded-file-recursive?))
  94
  95 (define download-to-store*
  96   (store-lift download-to-store))
  97
  98 (define-gexp-compiler (compile-downloaded-file (file <downloaded-file>)
  99                                                system target)
 100   "Download FILE and return the result as a store item."
 101   (match file
 102     (($ <downloaded-file> uri recursive?)
 103      (download-to-store* uri #:recursive? recursive?))))
 104
 105 (define* (package-with-source p uri #:optional version)
 106   "Return a package based on P but with its source taken from URI.  Extract
 107 the new package's version number from URI."
 108   (let ((base (tarball-base-name (basename uri))))
 109     (let-values (((_ version*)
 110                   (hyphen-package-name->name+version base)))
 111       (package (inherit p)
 112                (version (or version version*
 113                             (package-version p)))
 114
 115                ;; Use #:recursive? #t to allow for directories.
 116                (source (downloaded-file uri #t))))))
 117
 118 \f
 119 ;;;
 120 ;;; Transformations.
 121 ;;;
 122
 123 (define (transform-package-source sources)
 124   "Return a transformation procedure that replaces package sources with the
 125 matching URIs given in SOURCES."
 126   (define new-sources
 127     (map (lambda (uri)
 128            (match (string-index uri #\=)
 129              (#f
 130               ;; Determine the package name and version from URI.
 131               (call-with-values
 132                   (lambda ()
 133                     (hyphen-package-name->name+version
 134                      (tarball-base-name (basename uri))))
 135                 (lambda (name version)
 136                   (list name version uri))))
 137              (index
 138               ;; What's before INDEX is a "PKG@VER" or "PKG" spec.
 139               (call-with-values
 140                   (lambda ()
 141                     (package-name->name+version (string-take uri index)))
 142                 (lambda (name version)
 143                   (list name version
 144                         (string-drop uri (+ 1 index))))))))
 145          sources))
 146
 147   (lambda (obj)
 148     (let loop ((sources  new-sources)
 149                (result   '()))
 150       (match obj
 151         ((? package? p)
 152          (match (assoc-ref sources (package-name p))
 153            ((version source)
 154             (package-with-source p source version))
 155            (#f
 156             p)))
 157         (_
 158          obj)))))
 159
 160 (define (evaluate-replacement-specs specs proc)
 161   "Parse SPECS, a list of strings like \"guile=guile@2.1\" and return a list
 162 of package spec/procedure pairs as expected by 'package-input-rewriting/spec'.
 163 PROC is called with the package to be replaced and its replacement according
 164 to SPECS.  Raise an error if an element of SPECS uses invalid syntax, or if a
 165 package it refers to could not be found."
 166   (define not-equal
 167     (char-set-complement (char-set #\=)))
 168
 169   (map (lambda (spec)
 170          (match (string-tokenize spec not-equal)
 171            ((spec new)
 172             (cons spec
 173                   (let ((new (specification->package new)))
 174                     (lambda (old)
 175                       (proc old new)))))
 176            (x
 177             (raise (formatted-message
 178                     (G_ "invalid replacement specification: ~s")
 179                     spec)))))
 180        specs))
 181
 182 (define (transform-package-inputs replacement-specs)
 183   "Return a procedure that, when passed a package, replaces its direct
 184 dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
 185 strings like \"guile=guile@2.1\" meaning that, any dependency on a package
 186 called \"guile\" must be replaced with a dependency on a version 2.1 of
 187 \"guile\"."
 188   (let* ((replacements (evaluate-replacement-specs replacement-specs
 189                                                    (lambda (old new)
 190                                                      new)))
 191          (rewrite      (package-input-rewriting/spec replacements)))
 192     (lambda (obj)
 193       (if (package? obj)
 194           (rewrite obj)
 195           obj))))
 196
 197 (define (transform-package-inputs/graft replacement-specs)
 198   "Return a procedure that, when passed a package, replaces its direct
 199 dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
 200 strings like \"gnutls=gnutls@3.5.4\" meaning that packages are built using the
 201 current 'gnutls' package, after which version 3.5.4 is grafted onto them."
 202   (define (set-replacement old new)
 203     (package (inherit old) (replacement new)))
 204
 205   (let* ((replacements (evaluate-replacement-specs replacement-specs
 206                                                    set-replacement))
 207          (rewrite      (package-input-rewriting/spec replacements)))
 208     (lambda (obj)
 209       (if (package? obj)
 210           (rewrite obj)
 211           obj))))
 212
 213 (define %not-equal
 214   (char-set-complement (char-set #\=)))
 215
 216 (define (package-git-url package)
 217   "Return the URL of the Git repository for package, or raise an error if
 218 the source of PACKAGE is not fetched from a Git repository."
 219   (let ((source (package-source package)))
 220     (cond ((and (origin? source)
 221                 (git-reference? (origin-uri source)))
 222            (git-reference-url (origin-uri source)))
 223           ((git-checkout? source)
 224            (git-checkout-url source))
 225           (else
 226            (raise
 227             (formatted-message (G_ "the source of ~a is not a Git reference")
 228                                (package-full-name package)))))))
 229
 230 (define (evaluate-git-replacement-specs specs proc)
 231   "Parse SPECS, a list of strings like \"guile=stable-2.2\", and return a list
 232 of package pairs, where (PROC PACKAGE URL BRANCH-OR-COMMIT) returns the
 233 replacement package.  Raise an error if an element of SPECS uses invalid
 234 syntax, or if a package it refers to could not be found."
 235   (map (lambda (spec)
 236          (match (string-tokenize spec %not-equal)
 237            ((spec branch-or-commit)
 238             (define (replace old)
 239               (let* ((source (package-source old))
 240                      (url    (package-git-url old)))
 241                 (proc old url branch-or-commit)))
 242
 243             (cons spec replace))
 244            (_
 245             (raise
 246              (formatted-message (G_ "invalid replacement specification: ~s")
 247                                 spec)))))
 248        specs))
 249
 250 (define (transform-package-source-branch replacement-specs)
 251   "Return a procedure that, when passed a package, replaces its direct
 252 dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
 253 strings like \"guile-next=stable-3.0\" meaning that packages are built using
 254 'guile-next' from the latest commit on its 'stable-3.0' branch."
 255   (define (replace old url branch)
 256     (package
 257       (inherit old)
 258       (version (string-append "git." (string-map (match-lambda
 259                                                    (#\/ #\-)
 260                                                    (chr chr))
 261                                                  branch)))
 262       (source (git-checkout (url url) (branch branch)
 263                             (recursive? #t)))))
 264
 265   (let* ((replacements (evaluate-git-replacement-specs replacement-specs
 266                                                        replace))
 267          (rewrite      (package-input-rewriting/spec replacements)))
 268     (lambda (obj)
 269       (if (package? obj)
 270           (rewrite obj)
 271           obj))))
 272
 273 (define (transform-package-source-commit replacement-specs)
 274   "Return a procedure that, when passed a package, replaces its direct
 275 dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
 276 strings like \"guile-next=cabba9e\" meaning that packages are built using
 277 'guile-next' from commit 'cabba9e'."
 278   (define (replace old url commit)
 279     (package
 280       (inherit old)
 281       (version (if (and (> (string-length commit) 1)
 282                         (string-prefix? "v" commit)
 283                         (char-set-contains? char-set:digit
 284                                             (string-ref commit 1)))
 285                    (string-drop commit 1)        ;looks like a tag like "v1.0"
 286                    (string-append "git."
 287                                   (if (< (string-length commit) 7)
 288                                       commit
 289                                       (string-take commit 7)))))
 290       (source (git-checkout (url url) (commit commit)
 291                             (recursive? #t)))))
 292
 293   (let* ((replacements (evaluate-git-replacement-specs replacement-specs
 294                                                        replace))
 295          (rewrite      (package-input-rewriting/spec replacements)))
 296     (lambda (obj)
 297       (if (package? obj)
 298           (rewrite obj)
 299           obj))))
 300
 301 (define (transform-package-source-git-url replacement-specs)
 302   "Return a procedure that, when passed a package, replaces its dependencies
 303 according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of strings like
 304 \"guile-json=https://gitthing.com/…\" meaning that packages are built using
 305 a checkout of the Git repository at the given URL."
 306   (define replacements
 307     (map (lambda (spec)
 308            (match (string-tokenize spec %not-equal)
 309              ((spec url)
 310               (cons spec
 311                     (lambda (old)
 312                       (package
 313                         (inherit old)
 314                         (source (git-checkout (url url)
 315                                               (recursive? #t)))))))
 316              (_
 317               (raise
 318                (formatted-message
 319                 (G_ "~a: invalid Git URL replacement specification")
 320                 spec)))))
 321          replacement-specs))
 322
 323   (define rewrite
 324     (package-input-rewriting/spec replacements))
 325
 326   (lambda (obj)
 327     (if (package? obj)
 328         (rewrite obj)
 329         obj)))
 330
 331 (define (package-dependents/spec top bottom)
 332   "Return the list of dependents of BOTTOM, a spec string, that are also
 333 dependencies of TOP, a package."
 334   (define-values (name version)
 335     (package-name->name+version bottom))
 336
 337   (define dependent?
 338     (mlambda (p)
 339       (and (package? p)
 340            (or (and (string=? name (package-name p))
 341                     (or (not version)
 342                         (version-prefix? version (package-version p))))
 343                (match (bag-direct-inputs (package->bag p))
 344                  (((labels dependencies . _) ...)
 345                   (any dependent? dependencies)))))))
 346
 347   (filter dependent? (package-closure (list top))))
 348
 349 (define (package-toolchain-rewriting p bottom toolchain)
 350   "Return a procedure that, when passed a package that's either BOTTOM or one
 351 of its dependents up to P so, changes it so it is built with TOOLCHAIN.
 352 TOOLCHAIN must be an input list."
 353   (define rewriting-property
 354     (gensym " package-toolchain-rewriting"))
 355
 356   (match (package-dependents/spec p bottom)
 357     (()                                           ;P does not depend on BOTTOM
 358      identity)
 359     (set
 360      ;; SET is the list of packages "between" P and BOTTOM (included) whose
 361      ;; toolchain needs to be changed.
 362      (package-mapping (lambda (p)
 363                         (if (or (assq rewriting-property
 364                                       (package-properties p))
 365                                 (not (memq p set)))
 366                             p
 367                             (let ((p (package-with-c-toolchain p toolchain)))
 368                               (package/inherit p
 369                                 (properties `((,rewriting-property . #t)
 370                                               ,@(package-properties p)))))))
 371                       (lambda (p)
 372                         (or (assq rewriting-property (package-properties p))
 373                             (not (memq p set))))
 374                       #:deep? #t))))
 375
 376 (define (transform-package-toolchain replacement-specs)
 377   "Return a procedure that, when passed a package, changes its toolchain or
 378 that of its dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is
 379 a list of strings like \"fftw=gcc-toolchain@10\" meaning that the package to
 380 the left of the equal sign must be built with the toolchain to the right of
 381 the equal sign."
 382   (define split-on-commas
 383     (cute string-tokenize <> (char-set-complement (char-set #\,))))
 384
 385   (define (specification->input spec)
 386     (let ((package (specification->package spec)))
 387       (list (package-name package) package)))
 388
 389   (define replacements
 390     (map (lambda (spec)
 391            (match (string-tokenize spec %not-equal)
 392              ((spec (= split-on-commas toolchain))
 393               (cons spec (map specification->input toolchain)))
 394              (_
 395               (raise
 396                (formatted-message
 397                 (G_ "~a: invalid toolchain replacement specification")
 398                 spec)))))
 399          replacement-specs))
 400
 401   (lambda (obj)
 402     (if (package? obj)
 403         (or (any (match-lambda
 404                    ((bottom . toolchain)
 405                     ((package-toolchain-rewriting obj bottom toolchain) obj)))
 406                  replacements)
 407             obj)
 408         obj)))
 409
 410 (define (transform-package-with-debug-info specs)
 411   "Return a procedure that, when passed a package, set its 'replacement' field
 412 to the same package but with #:strip-binaries? #f in its 'arguments' field."
 413   (define (non-stripped p)
 414     (package
 415       (inherit p)
 416       (arguments
 417        (substitute-keyword-arguments (package-arguments p)
 418          ((#:strip-binaries? _ #f) #f)))))
 419
 420   (define (package-with-debug-info p)
 421     (if (member "debug" (package-outputs p))
 422         p
 423         (let loop ((p p))
 424           (match (package-replacement p)
 425             (#f
 426              (package
 427                (inherit p)
 428                (replacement (non-stripped p))))
 429             (next
 430              (package
 431                (inherit p)
 432                (replacement (loop next))))))))
 433
 434   (define rewrite
 435     (package-input-rewriting/spec (map (lambda (spec)
 436                                          (cons spec package-with-debug-info))
 437                                        specs)))
 438
 439   (lambda (obj)
 440     (if (package? obj)
 441         (rewrite obj)
 442         obj)))
 443
 444 (define (transform-package-tests specs)
 445   "Return a procedure that, when passed a package, sets #:tests? #f in its
 446 'arguments' field."
 447   (define (package-without-tests p)
 448     (package/inherit p
 449       (arguments
 450        (substitute-keyword-arguments (package-arguments p)
 451          ((#:tests? _ #f) #f)))))
 452
 453   (define rewrite
 454     (package-input-rewriting/spec (map (lambda (spec)
 455                                          (cons spec package-without-tests))
 456                                        specs)))
 457
 458   (lambda (obj)
 459     (if (package? obj)
 460         (rewrite obj)
 461         obj)))
 462
 463 (define (transform-package-patches specs)
 464   "Return a procedure that, when passed a package, returns a package with
 465 additional patches."
 466   (define (package-with-extra-patches p patches)
 467     (if (origin? (package-source p))
 468         (package/inherit p
 469           (source (origin
 470                     (inherit (package-source p))
 471                     (patches (append (map (lambda (file)
 472                                             (local-file file))
 473                                           patches)
 474                                      (origin-patches (package-source p)))))))
 475         p))
 476
 477   (define (coalesce-alist alist)
 478     ;; Coalesce multiple occurrences of the same key in ALIST.
 479     (let loop ((alist alist)
 480                (keys '())
 481                (mapping vlist-null))
 482       (match alist
 483         (()
 484          (map (lambda (key)
 485                 (cons key (vhash-fold* cons '() key mapping)))
 486               (delete-duplicates (reverse keys))))
 487         (((key . value) . rest)
 488          (loop rest
 489                (cons key keys)
 490                (vhash-cons key value mapping))))))
 491
 492   (define patches
 493     ;; Spec/patch alist.
 494     (coalesce-alist
 495      (map (lambda (spec)
 496             (match (string-tokenize spec %not-equal)
 497               ((spec patch)
 498                (cons spec (canonicalize-path patch)))
 499               (_
 500                (raise (formatted-message
 501                        (G_ "~a: invalid package patch specification")
 502                        spec)))))
 503           specs)))
 504
 505   (define rewrite
 506     (package-input-rewriting/spec
 507      (map (match-lambda
 508             ((spec . patches)
 509              (cons spec (cut package-with-extra-patches <> patches))))
 510           patches)))
 511
 512   (lambda (obj)
 513     (if (package? obj)
 514         (rewrite obj)
 515         obj)))
 516
 517 (define (transform-package-latest specs)
 518   "Return a procedure that rewrites package graphs such that those in SPECS
 519 are replaced by their latest upstream version."
 520   (define (package-with-latest-upstream p)
 521     (let ((source (package-latest-release* p)))
 522       (cond ((not source)
 523              (warning
 524               (G_ "could not determine latest upstream release of '~a'~%")
 525               (package-name p))
 526              p)
 527             ((string=? (upstream-source-version source)
 528                        (package-version p))
 529              p)
 530             (else
 531              (unless (pair? (upstream-source-signature-urls source))
 532                (warning (G_ "cannot authenticate source of '~a', version ~a~%")
 533                         (package-name p)
 534                         (upstream-source-version source)))
 535
 536              ;; TODO: Take 'upstream-source-input-changes' into account.
 537              (package
 538                (inherit p)
 539                (version (upstream-source-version source))
 540                (source source))))))
 541
 542   (define rewrite
 543     (package-input-rewriting/spec
 544      (map (lambda (spec)
 545             (cons spec package-with-latest-upstream))
 546           specs)))
 547
 548   (lambda (obj)
 549     (if (package? obj)
 550         (rewrite obj)
 551         obj)))
 552
 553 (define %transformations
 554   ;; Transformations that can be applied to things to build.  The car is the
 555   ;; key used in the option alist, and the cdr is the transformation
 556   ;; procedure; it is called with two arguments: the store, and a list of
 557   ;; things to build.
 558   `((with-source . ,transform-package-source)
 559     (with-input  . ,transform-package-inputs)
 560     (with-graft  . ,transform-package-inputs/graft)
 561     (with-branch . ,transform-package-source-branch)
 562     (with-commit . ,transform-package-source-commit)
 563     (with-git-url . ,transform-package-source-git-url)
 564     (with-c-toolchain . ,transform-package-toolchain)
 565     (with-debug-info . ,transform-package-with-debug-info)
 566     (without-tests . ,transform-package-tests)
 567     (with-patch  . ,transform-package-patches)
 568     (with-latest . ,transform-package-latest)))
 569
 570 (define (transformation-procedure key)
 571   "Return the transformation procedure associated with KEY, a symbol such as
 572 'with-source', or #f if there is none."
 573   (any (match-lambda
 574          ((k . proc)
 575           (and (eq? k key) proc)))
 576        %transformations))
 577
 578 \f
 579 ;;;
 580 ;;; Command-line handling.
 581 ;;;
 582
 583 (define %transformation-options
 584   ;; The command-line interface to the above transformations.
 585   (let ((parser (lambda (symbol)
 586                   (lambda (opt name arg result . rest)
 587                     (apply values
 588                            (alist-cons symbol arg result)
 589                            rest)))))
 590     (list (option '("with-source") #t #f
 591                   (parser 'with-source))
 592           (option '("with-input") #t #f
 593                   (parser 'with-input))
 594           (option '("with-graft") #t #f
 595                   (parser 'with-graft))
 596           (option '("with-branch") #t #f
 597                   (parser 'with-branch))
 598           (option '("with-commit") #t #f
 599                   (parser 'with-commit))
 600           (option '("with-git-url") #t #f
 601                   (parser 'with-git-url))
 602           (option '("with-c-toolchain") #t #f
 603                   (parser 'with-c-toolchain))
 604           (option '("with-debug-info") #t #f
 605                   (parser 'with-debug-info))
 606           (option '("without-tests") #t #f
 607                   (parser 'without-tests))
 608           (option '("with-patch") #t #f
 609                   (parser 'with-patch))
 610           (option '("with-latest") #t #f
 611                   (parser 'with-latest))
 612
 613           (option '("help-transform") #f #f
 614                   (lambda _
 615                     (format #t
 616                             (G_ "Available package transformation options:~%"))
 617                     (show-transformation-options-help/detailed)
 618                     (newline)
 619                     (exit 0))))))
 620
 621 (define (show-transformation-options-help/detailed)
 622   (display (G_ "
 623       --with-source=[PACKAGE=]SOURCE
 624                          use SOURCE when building the corresponding package"))
 625   (display (G_ "
 626       --with-input=PACKAGE=REPLACEMENT
 627                          replace dependency PACKAGE by REPLACEMENT"))
 628   (display (G_ "
 629       --with-graft=PACKAGE=REPLACEMENT
 630                          graft REPLACEMENT on packages that refer to PACKAGE"))
 631   (display (G_ "
 632       --with-branch=PACKAGE=BRANCH
 633                          build PACKAGE from the latest commit of BRANCH"))
 634   (display (G_ "
 635       --with-commit=PACKAGE=COMMIT
 636                          build PACKAGE from COMMIT"))
 637   (display (G_ "
 638       --with-git-url=PACKAGE=URL
 639                          build PACKAGE from the repository at URL"))
 640   (display (G_ "
 641       --with-patch=PACKAGE=FILE
 642                          add FILE to the list of patches of PACKAGE"))
 643   (display (G_ "
 644       --with-latest=PACKAGE
 645                          use the latest upstream release of PACKAGE"))
 646   (display (G_ "
 647       --with-c-toolchain=PACKAGE=TOOLCHAIN
 648                          build PACKAGE and its dependents with TOOLCHAIN"))
 649   (display (G_ "
 650       --with-debug-info=PACKAGE
 651                          build PACKAGE and preserve its debug info"))
 652   (display (G_ "
 653       --without-tests=PACKAGE
 654                          build PACKAGE without running its tests")))
 655
 656 (define (show-transformation-options-help)
 657   "Show basic help for package transformation options."
 658   (display (G_ "
 659       --help-transform   list package transformation options not shown here")))
 660
 661 (define (options->transformation opts)
 662   "Return a procedure that, when passed an object to build (package,
 663 derivation, etc.), applies the transformations specified by OPTS and returns
 664 the resulting objects.  OPTS must be a list of symbol/string pairs such as:
 665
 666   ((with-branch . \"guile-gcrypt=master\")
 667    (without-tests . \"libgcrypt\"))
 668
 669 Each symbol names a transformation and the corresponding string is an argument
 670 to that transformation."
 671   (define applicable
 672     ;; List of applicable transformations as symbol/procedure pairs in the
 673     ;; order in which they appear on the command line.
 674     (filter-map (match-lambda
 675                   ((key . value)
 676                    (match (transformation-procedure key)
 677                      (#f
 678                       #f)
 679                      (transform
 680                       ;; XXX: We used to pass TRANSFORM a list of several
 681                       ;; arguments, but we now pass only one, assuming that
 682                       ;; transform composes well.
 683                       (list key value (transform (list value)))))))
 684                 (reverse opts)))
 685
 686   (define (package-with-transformation-properties p)
 687     (package/inherit p
 688       (properties `((transformations
 689                      . ,(map (match-lambda
 690                                ((key value _)
 691                                 (cons key value)))
 692                              applicable))
 693                     ,@(package-properties p)))))
 694
 695   (lambda (obj)
 696     (define (tagged-object new)
 697       (if (and (not (eq? obj new))
 698                (package? new) (not (null? applicable)))
 699           (package-with-transformation-properties new)
 700           new))
 701
 702     (tagged-object
 703      (fold (match-lambda*
 704              (((name value transform) obj)
 705               (let ((new (transform obj)))
 706                 (when (eq? new obj)
 707                   (warning (G_ "transformation '~a' had no effect on ~a~%")
 708                            name
 709                            (if (package? obj)
 710                                (package-full-name obj)
 711                                obj)))
 712                 new)))
 713            obj
 714            applicable))))
 715
 716 (define (package-transformations package)
 717   "Return the transformations applied to PACKAGE according to its properties."
 718   (match (assq-ref (package-properties package) 'transformations)
 719     (#f '())
 720     (transformations transformations)))
 721
 722 (define (manifest-entry-with-transformations entry)
 723   "Return ENTRY with an additional 'transformations' property if it's not
 724 already there."
 725   (let ((properties (manifest-entry-properties entry)))
 726     (if (assq 'transformations properties)
 727         entry
 728         (let ((item (manifest-entry-item entry)))
 729           (manifest-entry
 730             (inherit entry)
 731             (properties
 732              (match (and (package? item)
 733                          (package-transformations item))
 734                ((or #f '())
 735                 properties)
 736                (transformations
 737                 `((transformations . ,transformations)
 738                   ,@properties)))))))))