guix/transformations.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016-2022 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2021 Marius Bakke <marius@gnu.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (guix transformations)
  21   #:use-module ((guix config) #:select (%system))
  22   #:use-module (guix i18n)
  23   #:use-module (guix store)
  24   #:use-module (guix packages)
  25   #:use-module (guix build-system)
  26   #:use-module (guix profiles)
  27   #:use-module (guix diagnostics)
  28   #:autoload   (guix download) (download-to-store)
  29   #:autoload   (guix git-download) (git-reference? git-reference-url)
  30   #:autoload   (guix git) (git-checkout git-checkout? git-checkout-url)
  31   #:autoload   (guix upstream) (package-latest-release
  32                                 upstream-source-version
  33                                 upstream-source-signature-urls)
  34   #:autoload   (guix cpu) (current-cpu cpu->gcc-architecture)
  35   #:use-module (guix utils)
  36   #:use-module (guix memoization)
  37   #:use-module (guix gexp)
  38
  39   ;; Use the procedure that destructures "NAME-VERSION" forms.
  40   #:use-module ((guix build utils)
  41                 #:select ((package-name->name+version
  42                            . hyphen-package-name->name+version)))
  43
  44   #:use-module (srfi srfi-1)
  45   #:use-module (srfi srfi-9)
  46   #:use-module (srfi srfi-11)
  47   #:use-module (srfi srfi-26)
  48   #:use-module (srfi srfi-34)
  49   #:use-module (srfi srfi-35)
  50   #:use-module (srfi srfi-37)
  51   #:use-module (ice-9 match)
  52   #:use-module (ice-9 vlist)
  53   #:export (options->transformation
  54             manifest-entry-with-transformations
  55
  56             tunable-package?
  57             tuned-package
  58
  59             show-transformation-options-help
  60             transformation-option-key?
  61             %transformation-options))
  62
  63 ;;; Commentary:
  64 ;;;
  65 ;;; This module implements "package transformation options"---tools for
  66 ;;; package graph rewriting.  It contains the graph rewriting logic, but also
  67 ;;; the tip of its user interface: command-line option handling.
  68 ;;;
  69 ;;; Code:
  70
  71 (module-autoload! (current-module) '(gnu packages)
  72                   '(specification->package))
  73
  74 (define (numeric-extension? file-name)
  75   "Return true if FILE-NAME ends with digits."
  76   (string-every char-set:hex-digit (file-extension file-name)))
  77
  78 (define (tarball-base-name file-name)
  79   "Return the \"base\" of FILE-NAME, removing '.tar.gz' or similar
  80 extensions."
  81   ;; TODO: Factorize.
  82   (cond ((not (file-extension file-name))
  83          file-name)
  84         ((numeric-extension? file-name)
  85          file-name)
  86         ((string=? (file-extension file-name) "tar")
  87          (file-sans-extension file-name))
  88         ((file-extension file-name)
  89          =>
  90          (match-lambda
  91            ("scm" file-name)
  92            (_     (tarball-base-name (file-sans-extension file-name)))))
  93         (else
  94          file-name)))
  95
  96
  97 ;; Files to be downloaded.
  98 (define-record-type <downloaded-file>
  99   (downloaded-file uri recursive?)
 100   downloaded-file?
 101   (uri        downloaded-file-uri)
 102   (recursive? downloaded-file-recursive?))
 103
 104 (define download-to-store*
 105   (store-lift download-to-store))
 106
 107 (define-gexp-compiler (compile-downloaded-file (file <downloaded-file>)
 108                                                system target)
 109   "Download FILE and return the result as a store item."
 110   (match file
 111     (($ <downloaded-file> uri recursive?)
 112      (download-to-store* uri #:recursive? recursive?))))
 113
 114 (define* (package-with-source p uri #:optional version)
 115   "Return a package based on P but with its source taken from URI.  Extract
 116 the new package's version number from URI."
 117   (let ((base (tarball-base-name (basename uri))))
 118     (let-values (((_ version*)
 119                   (hyphen-package-name->name+version base)))
 120       (package (inherit p)
 121                (version (or version version*
 122                             (package-version p)))
 123
 124                ;; Use #:recursive? #t to allow for directories.
 125                (source (downloaded-file uri #t))))))
 126
 127 \f
 128 ;;;
 129 ;;; Transformations.
 130 ;;;
 131
 132 (define (transform-package-source sources)
 133   "Return a transformation procedure that replaces package sources with the
 134 matching URIs given in SOURCES."
 135   (define new-sources
 136     (map (lambda (uri)
 137            (match (string-index uri #\=)
 138              (#f
 139               ;; Determine the package name and version from URI.
 140               (call-with-values
 141                   (lambda ()
 142                     (hyphen-package-name->name+version
 143                      (tarball-base-name (basename uri))))
 144                 (lambda (name version)
 145                   (list name version uri))))
 146              (index
 147               ;; What's before INDEX is a "PKG@VER" or "PKG" spec.
 148               (call-with-values
 149                   (lambda ()
 150                     (package-name->name+version (string-take uri index)))
 151                 (lambda (name version)
 152                   (list name version
 153                         (string-drop uri (+ 1 index))))))))
 154          sources))
 155
 156   (lambda (obj)
 157     (let loop ((sources  new-sources)
 158                (result   '()))
 159       (match obj
 160         ((? package? p)
 161          (match (assoc-ref sources (package-name p))
 162            ((version source)
 163             (package-with-source p source version))
 164            (#f
 165             p)))
 166         (_
 167          obj)))))
 168
 169 (define (evaluate-replacement-specs specs proc)
 170   "Parse SPECS, a list of strings like \"guile=guile@2.1\" and return a list
 171 of package spec/procedure pairs as expected by 'package-input-rewriting/spec'.
 172 PROC is called with the package to be replaced and its replacement according
 173 to SPECS.  Raise an error if an element of SPECS uses invalid syntax, or if a
 174 package it refers to could not be found."
 175   (define not-equal
 176     (char-set-complement (char-set #\=)))
 177
 178   (map (lambda (spec)
 179          (match (string-tokenize spec not-equal)
 180            ((spec new)
 181             (cons spec
 182                   (let ((new (specification->package new)))
 183                     (lambda (old)
 184                       (proc old new)))))
 185            (x
 186             (raise (formatted-message
 187                     (G_ "invalid replacement specification: ~s")
 188                     spec)))))
 189        specs))
 190
 191 (define (transform-package-inputs replacement-specs)
 192   "Return a procedure that, when passed a package, replaces its direct
 193 dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
 194 strings like \"guile=guile@2.1\" meaning that, any dependency on a package
 195 called \"guile\" must be replaced with a dependency on a version 2.1 of
 196 \"guile\"."
 197   (let* ((replacements (evaluate-replacement-specs replacement-specs
 198                                                    (lambda (old new)
 199                                                      new)))
 200          (rewrite      (package-input-rewriting/spec replacements)))
 201     (lambda (obj)
 202       (if (package? obj)
 203           (rewrite obj)
 204           obj))))
 205
 206 (define (transform-package-inputs/graft replacement-specs)
 207   "Return a procedure that, when passed a package, replaces its direct
 208 dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
 209 strings like \"gnutls=gnutls@3.5.4\" meaning that packages are built using the
 210 current 'gnutls' package, after which version 3.5.4 is grafted onto them."
 211   (define (set-replacement old new)
 212     (package (inherit old) (replacement new)))
 213
 214   (let* ((replacements (evaluate-replacement-specs replacement-specs
 215                                                    set-replacement))
 216          (rewrite      (package-input-rewriting/spec replacements)))
 217     (lambda (obj)
 218       (if (package? obj)
 219           (rewrite obj)
 220           obj))))
 221
 222 (define %not-equal
 223   (char-set-complement (char-set #\=)))
 224
 225 (define (package-git-url package)
 226   "Return the URL of the Git repository for package, or raise an error if
 227 the source of PACKAGE is not fetched from a Git repository."
 228   (let ((source (package-source package)))
 229     (cond ((and (origin? source)
 230                 (git-reference? (origin-uri source)))
 231            (git-reference-url (origin-uri source)))
 232           ((git-checkout? source)
 233            (git-checkout-url source))
 234           (else
 235            (raise
 236             (formatted-message (G_ "the source of ~a is not a Git reference")
 237                                (package-full-name package)))))))
 238
 239 (define (evaluate-git-replacement-specs specs proc)
 240   "Parse SPECS, a list of strings like \"guile=stable-2.2\", and return a list
 241 of package pairs, where (PROC PACKAGE URL BRANCH-OR-COMMIT) returns the
 242 replacement package.  Raise an error if an element of SPECS uses invalid
 243 syntax, or if a package it refers to could not be found."
 244   (map (lambda (spec)
 245          (match (string-tokenize spec %not-equal)
 246            ((spec branch-or-commit)
 247             (define (replace old)
 248               (let* ((source (package-source old))
 249                      (url    (package-git-url old)))
 250                 (proc old url branch-or-commit)))
 251
 252             (cons spec replace))
 253            (_
 254             (raise
 255              (formatted-message (G_ "invalid replacement specification: ~s")
 256                                 spec)))))
 257        specs))
 258
 259 (define (transform-package-source-branch replacement-specs)
 260   "Return a procedure that, when passed a package, replaces its direct
 261 dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
 262 strings like \"guile-next=stable-3.0\" meaning that packages are built using
 263 'guile-next' from the latest commit on its 'stable-3.0' branch."
 264   (define (replace old url branch)
 265     (package
 266       (inherit old)
 267       (version (string-append "git." (string-map (match-lambda
 268                                                    (#\/ #\-)
 269                                                    (chr chr))
 270                                                  branch)))
 271       (source (git-checkout (url url) (branch branch)
 272                             (recursive? #t)))))
 273
 274   (let* ((replacements (evaluate-git-replacement-specs replacement-specs
 275                                                        replace))
 276          (rewrite      (package-input-rewriting/spec replacements)))
 277     (lambda (obj)
 278       (if (package? obj)
 279           (rewrite obj)
 280           obj))))
 281
 282 (define (commit->version-string commit)
 283   "Return a string suitable for use in the 'version' field of a package based
 284 on the given COMMIT."
 285   (cond ((and (> (string-length commit) 1)
 286               (string-prefix? "v" commit)
 287               (char-set-contains? char-set:digit
 288                                   (string-ref commit 1)))
 289          ;; Probably a tag like "v1.0" or a 'git describe' identifier.
 290          (string-drop commit 1))
 291         ((not (string-every char-set:hex-digit commit))
 292          ;; Pass through tags and 'git describe' style IDs directly.
 293          commit)
 294         (else
 295          (string-append "git."
 296                         (if (< (string-length commit) 7)
 297                             commit
 298                             (string-take commit 7))))))
 299
 300
 301 (define (transform-package-source-commit replacement-specs)
 302   "Return a procedure that, when passed a package, replaces its direct
 303 dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
 304 strings like \"guile-next=cabba9e\" meaning that packages are built using
 305 'guile-next' from commit 'cabba9e'."
 306   (define (replace old url commit)
 307     (package
 308       (inherit old)
 309       (version (commit->version-string commit))
 310       (source (git-checkout (url url) (commit commit)
 311                             (recursive? #t)))))
 312
 313   (let* ((replacements (evaluate-git-replacement-specs replacement-specs
 314                                                        replace))
 315          (rewrite      (package-input-rewriting/spec replacements)))
 316     (lambda (obj)
 317       (if (package? obj)
 318           (rewrite obj)
 319           obj))))
 320
 321 (define (transform-package-source-git-url replacement-specs)
 322   "Return a procedure that, when passed a package, replaces its dependencies
 323 according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of strings like
 324 \"guile-json=https://gitthing.com/…\" meaning that packages are built using
 325 a checkout of the Git repository at the given URL."
 326   (define replacements
 327     (map (lambda (spec)
 328            (match (string-tokenize spec %not-equal)
 329              ((spec url)
 330               (cons spec
 331                     (lambda (old)
 332                       (package
 333                         (inherit old)
 334                         (source (git-checkout (url url)
 335                                               (recursive? #t)))))))
 336              (_
 337               (raise
 338                (formatted-message
 339                 (G_ "~a: invalid Git URL replacement specification")
 340                 spec)))))
 341          replacement-specs))
 342
 343   (define rewrite
 344     (package-input-rewriting/spec replacements))
 345
 346   (lambda (obj)
 347     (if (package? obj)
 348         (rewrite obj)
 349         obj)))
 350
 351 (define (package-dependents/spec top bottom)
 352   "Return the list of dependents of BOTTOM, a spec string, that are also
 353 dependencies of TOP, a package."
 354   (define-values (name version)
 355     (package-name->name+version bottom))
 356
 357   (define dependent?
 358     (mlambda (p)
 359       (and (package? p)
 360            (or (and (string=? name (package-name p))
 361                     (or (not version)
 362                         (version-prefix? version (package-version p))))
 363                (match (bag-direct-inputs (package->bag p))
 364                  (((labels dependencies . _) ...)
 365                   (any dependent? dependencies)))))))
 366
 367   (filter dependent? (package-closure (list top))))
 368
 369 (define (package-toolchain-rewriting p bottom toolchain)
 370   "Return a procedure that, when passed a package that's either BOTTOM or one
 371 of its dependents up to P so, changes it so it is built with TOOLCHAIN.
 372 TOOLCHAIN must be an input list."
 373   (define rewriting-property
 374     (gensym " package-toolchain-rewriting"))
 375
 376   (match (package-dependents/spec p bottom)
 377     (()                                           ;P does not depend on BOTTOM
 378      identity)
 379     (set
 380      ;; SET is the list of packages "between" P and BOTTOM (included) whose
 381      ;; toolchain needs to be changed.
 382      (package-mapping (lambda (p)
 383                         (if (or (assq rewriting-property
 384                                       (package-properties p))
 385                                 (not (memq p set)))
 386                             p
 387                             (let ((p (package-with-c-toolchain p toolchain)))
 388                               (package/inherit p
 389                                 (properties `((,rewriting-property . #t)
 390                                               ,@(package-properties p)))))))
 391                       (lambda (p)
 392                         (or (assq rewriting-property (package-properties p))
 393                             (not (memq p set))))
 394                       #:deep? #t))))
 395
 396 (define (transform-package-toolchain replacement-specs)
 397   "Return a procedure that, when passed a package, changes its toolchain or
 398 that of its dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is
 399 a list of strings like \"fftw=gcc-toolchain@10\" meaning that the package to
 400 the left of the equal sign must be built with the toolchain to the right of
 401 the equal sign."
 402   (define split-on-commas
 403     (cute string-tokenize <> (char-set-complement (char-set #\,))))
 404
 405   (define (specification->input spec)
 406     (let ((package (specification->package spec)))
 407       (list (package-name package) package)))
 408
 409   (define replacements
 410     (map (lambda (spec)
 411            (match (string-tokenize spec %not-equal)
 412              ((spec (= split-on-commas toolchain))
 413               (cons spec (map specification->input toolchain)))
 414              (_
 415               (raise
 416                (formatted-message
 417                 (G_ "~a: invalid toolchain replacement specification")
 418                 spec)))))
 419          replacement-specs))
 420
 421   (lambda (obj)
 422     (if (package? obj)
 423         (or (any (match-lambda
 424                    ((bottom . toolchain)
 425                     ((package-toolchain-rewriting obj bottom toolchain) obj)))
 426                  replacements)
 427             obj)
 428         obj)))
 429
 430 (define tuning-compiler
 431   (mlambda (micro-architecture)
 432     "Return a compiler wrapper that passes '-march=MICRO-ARCHITECTURE' to the
 433 actual compiler."
 434     (define wrapper
 435       #~(begin
 436           (use-modules (ice-9 match))
 437
 438           (define* (search-next command
 439                                 #:optional
 440                                 (path (string-split (getenv "PATH")
 441                                                     #\:)))
 442             ;; Search the next COMMAND on PATH, a list of
 443             ;; directories representing the executable search path.
 444             (define this
 445               (stat (car (command-line))))
 446
 447             (let loop ((path path))
 448               (match path
 449                 (()
 450                  (match command
 451                    ("cc" (search-next "gcc"))
 452                    (_ #f)))
 453                 ((directory rest ...)
 454                  (let* ((file (string-append
 455                                directory "/" command))
 456                         (st   (stat file #f)))
 457                    (if (and st (not (equal? this st)))
 458                        file
 459                        (loop rest)))))))
 460
 461           (match (command-line)
 462             ((command arguments ...)
 463              (match (search-next (basename command))
 464                (#f (exit 127))
 465                (next
 466                 (apply execl next
 467                        (append (cons next arguments)
 468                            (list (string-append "-march="
 469                                                 #$micro-architecture))))))))))
 470
 471     (define program
 472       (program-file (string-append "tuning-compiler-wrapper-" micro-architecture)
 473                     wrapper))
 474
 475     (computed-file (string-append "tuning-compiler-" micro-architecture)
 476                    (with-imported-modules '((guix build utils))
 477                      #~(begin
 478                          (use-modules (guix build utils))
 479
 480                          (define bin (string-append #$output "/bin"))
 481                          (mkdir-p bin)
 482
 483                          (for-each (lambda (program)
 484                                      (symlink #$program
 485                                               (string-append bin "/" program)))
 486                                    '("cc" "gcc" "clang" "g++" "c++" "clang++")))))))
 487
 488 (define (build-system-with-tuning-compiler bs micro-architecture)
 489   "Return a variant of BS, a build system, that ensures that the compiler that
 490 BS uses (usually an implicit input) can generate code for MICRO-ARCHITECTURE,
 491 which names a specific CPU of the target architecture--e.g., when targeting
 492 86_64 MICRO-ARCHITECTURE might be \"skylake\".  If it does, return a build
 493 system that builds code for MICRO-ARCHITECTURE; otherwise raise an error."
 494   (define %not-hyphen
 495     (char-set-complement (char-set #\-)))
 496
 497   (define lower
 498     (build-system-lower bs))
 499
 500   (define (lower* . args)
 501     ;; The list of CPU names supported by the '-march' option of C/C++
 502     ;; compilers is specific to each compiler and version thereof.  Rather
 503     ;; than pass '-march=MICRO-ARCHITECTURE' as is to the compiler, possibly
 504     ;; leading to an obscure build error, check whether the compiler is known
 505     ;; to support MICRO-ARCHITECTURE.  If not, bail out.
 506     (let* ((lowered      (apply lower args))
 507            (architecture (match (string-tokenize (bag-system lowered)
 508                                                  %not-hyphen)
 509                            ((arch _ ...) arch)))
 510            (compiler     (any (match-lambda
 511                                 ((label (? package? p) . _)
 512                                  (and (assoc-ref (package-properties p)
 513                                                  'compiler-cpu-architectures)
 514                                       p))
 515                                 (_ #f))
 516                               (bag-build-inputs lowered))))
 517       (unless compiler
 518         (raise (formatted-message
 519                 (G_ "failed to determine which compiler is used"))))
 520
 521       (let ((lst (assoc-ref (package-properties compiler)
 522                             'compiler-cpu-architectures)))
 523         (unless lst
 524           (raise (formatted-message
 525                   (G_ "failed to determine whether ~a supports ~a")
 526                   (package-full-name compiler)
 527                   micro-architecture)))
 528         (unless (member micro-architecture
 529                         (or (assoc-ref lst architecture) '()))
 530           (raise
 531            (make-compound-condition
 532             (formatted-message
 533              (G_ "compiler ~a does not support micro-architecture ~a")
 534              (package-full-name compiler)
 535              micro-architecture)
 536             (condition
 537              (&fix-hint
 538               (hint (match (assoc-ref lst architecture)
 539                       (#f (format #f (G_ "Compiler ~a does not support
 540 micro-architectures of ~a.")
 541                                   (package-full-name compiler "@@")
 542                                   architecture))
 543                       (lst
 544                        (format #f (G_ "Compiler ~a supports the following ~a
 545 micro-architectures:
 546
 547 @quotation
 548 ~a
 549 @end quotation")
 550                                (package-full-name compiler "@@")
 551                                architecture
 552                                (string-join lst ", ")))))))))))
 553
 554       (bag
 555         (inherit lowered)
 556         (build-inputs
 557          ;; Arrange so that the compiler wrapper comes first in $PATH.
 558          `(("tuning-compiler" ,(tuning-compiler micro-architecture))
 559            ,@(bag-build-inputs lowered))))))
 560
 561   (build-system
 562     (inherit bs)
 563     (lower lower*)))
 564
 565 (define (tuned-package p micro-architecture)
 566   "Return package P tuned for MICRO-ARCHITECTURE."
 567   (package
 568     (inherit p)
 569     (build-system
 570       (build-system-with-tuning-compiler (package-build-system p)
 571                                          micro-architecture))
 572     (arguments
 573      ;; The machine building this package may or may not be able to run code
 574      ;; for MICRO-ARCHITECTURE.  Because of that, skip tests; they are run for
 575      ;; the "baseline" variant anyway.
 576      (substitute-keyword-arguments (package-arguments p)
 577        ((#:tests? _ #f) #f)))
 578
 579     (properties
 580      `((cpu-tuning . ,micro-architecture)
 581
 582        ;; Remove the 'tunable?' property so that 'package-tuning' does not
 583        ;; call 'tuned-package' again on this one.
 584        ,@(alist-delete 'tunable? (package-properties p))))))
 585
 586 (define (tunable-package? package)
 587   "Return true if package PACKAGE is \"tunable\"--i.e., if tuning it for the
 588 host CPU is worthwhile."
 589   (assq 'tunable? (package-properties package)))
 590
 591 (define package-tuning
 592   (mlambda (micro-architecture)
 593     "Return a procedure that maps the given package to its counterpart tuned
 594 for MICRO-ARCHITECTURE, a string suitable for GCC's '-march'."
 595     (define rewriting-property
 596       (gensym " package-tuning"))
 597
 598     (package-mapping (lambda (p)
 599                        (cond ((assq rewriting-property (package-properties p))
 600                               p)
 601                              ((assq 'tunable? (package-properties p))
 602                               (info (G_ "tuning ~a for CPU ~a~%")
 603                                     (package-full-name p) micro-architecture)
 604                               (package/inherit p
 605                                 (replacement (tuned-package p micro-architecture))
 606                                 (properties `((,rewriting-property . #t)
 607                                               ,@(package-properties p)))))
 608                              (else
 609                               p)))
 610                      (lambda (p)
 611                        (assq rewriting-property (package-properties p)))
 612                      #:deep? #t)))
 613
 614 (define (transform-package-tuning micro-architectures)
 615   "Return a procedure that, when "
 616   (match micro-architectures
 617     ((micro-architecture _ ...)
 618      (let ((rewrite (package-tuning micro-architecture)))
 619        (lambda (obj)
 620          (if (package? obj)
 621              (rewrite obj)
 622              obj))))))
 623
 624 (define (transform-package-with-debug-info specs)
 625   "Return a procedure that, when passed a package, set its 'replacement' field
 626 to the same package but with #:strip-binaries? #f in its 'arguments' field."
 627   (define (non-stripped p)
 628     (package
 629       (inherit p)
 630       (arguments
 631        (substitute-keyword-arguments (package-arguments p)
 632          ((#:strip-binaries? _ #f) #f)))))
 633
 634   (define (package-with-debug-info p)
 635     (if (member "debug" (package-outputs p))
 636         p
 637         (let loop ((p p))
 638           (match (package-replacement p)
 639             (#f
 640              (package
 641                (inherit p)
 642                (replacement (non-stripped p))))
 643             (next
 644              (package
 645                (inherit p)
 646                (replacement (loop next))))))))
 647
 648   (define rewrite
 649     (package-input-rewriting/spec (map (lambda (spec)
 650                                          (cons spec package-with-debug-info))
 651                                        specs)))
 652
 653   (lambda (obj)
 654     (if (package? obj)
 655         (rewrite obj)
 656         obj)))
 657
 658 (define (transform-package-tests specs)
 659   "Return a procedure that, when passed a package, sets #:tests? #f in its
 660 'arguments' field."
 661   (define (package-without-tests p)
 662     (package/inherit p
 663       (arguments
 664        (substitute-keyword-arguments (package-arguments p)
 665          ((#:tests? _ #f) #f)))))
 666
 667   (define rewrite
 668     (package-input-rewriting/spec (map (lambda (spec)
 669                                          (cons spec package-without-tests))
 670                                        specs)))
 671
 672   (lambda (obj)
 673     (if (package? obj)
 674         (rewrite obj)
 675         obj)))
 676
 677 (define (patched-source name source patches)
 678   "Return a file-like object with the given NAME that applies PATCHES to
 679 SOURCE.  SOURCE must itself be a file-like object of any type, including
 680 <git-checkout>, <local-file>, etc."
 681   (define patch
 682     (module-ref (resolve-interface '(gnu packages base)) 'patch))
 683
 684   (computed-file name
 685                  (with-imported-modules '((guix build utils))
 686                    #~(begin
 687                        (use-modules (guix build utils))
 688
 689                        (setenv "PATH" #+(file-append patch "/bin"))
 690
 691                        ;; XXX: Assume SOURCE is a directory.  This is true in
 692                        ;; most practical cases, where it's a <git-checkout>.
 693                        (copy-recursively #+source #$output)
 694                        (chdir #$output)
 695                        (for-each (lambda (patch)
 696                                    (invoke "patch" "-p1" "--batch"
 697                                            "-i" patch))
 698                                  '(#+@patches))))))
 699
 700 (define (transform-package-patches specs)
 701   "Return a procedure that, when passed a package, returns a package with
 702 additional patches."
 703   (define (package-with-extra-patches p patches)
 704     (let ((patches (map (lambda (file)
 705                           (local-file file))
 706                         patches)))
 707       (if (origin? (package-source p))
 708           (package/inherit p
 709             (source (origin
 710                       (inherit (package-source p))
 711                       (patches (append patches
 712                                        (origin-patches (package-source p)))))))
 713           (package/inherit p
 714             (source (patched-source (string-append (package-full-name p "-")
 715                                                    "-source")
 716                                     (package-source p) patches))))))
 717
 718   (define (coalesce-alist alist)
 719     ;; Coalesce multiple occurrences of the same key in ALIST.
 720     (let loop ((alist alist)
 721                (keys '())
 722                (mapping vlist-null))
 723       (match alist
 724         (()
 725          (map (lambda (key)
 726                 (cons key (vhash-fold* cons '() key mapping)))
 727               (delete-duplicates (reverse keys))))
 728         (((key . value) . rest)
 729          (loop rest
 730                (cons key keys)
 731                (vhash-cons key value mapping))))))
 732
 733   (define patches
 734     ;; Spec/patch alist.
 735     (coalesce-alist
 736      (map (lambda (spec)
 737             (match (string-tokenize spec %not-equal)
 738               ((spec patch)
 739                (cons spec (canonicalize-path patch)))
 740               (_
 741                (raise (formatted-message
 742                        (G_ "~a: invalid package patch specification")
 743                        spec)))))
 744           specs)))
 745
 746   (define rewrite
 747     (package-input-rewriting/spec
 748      (map (match-lambda
 749             ((spec . patches)
 750              (cons spec (cut package-with-extra-patches <> patches))))
 751           patches)))
 752
 753   (lambda (obj)
 754     (if (package? obj)
 755         (rewrite obj)
 756         obj)))
 757
 758 (define (transform-package-latest specs)
 759   "Return a procedure that rewrites package graphs such that those in SPECS
 760 are replaced by their latest upstream version."
 761   (define (package-with-latest-upstream p)
 762     (let ((source (package-latest-release p)))
 763       (cond ((not source)
 764              (warning
 765               (G_ "could not determine latest upstream release of '~a'~%")
 766               (package-name p))
 767              p)
 768             ((string=? (upstream-source-version source)
 769                        (package-version p))
 770              p)
 771             (else
 772              (unless (pair? (upstream-source-signature-urls source))
 773                (warning (G_ "cannot authenticate source of '~a', version ~a~%")
 774                         (package-name p)
 775                         (upstream-source-version source)))
 776
 777              ;; TODO: Take 'upstream-source-input-changes' into account.
 778              (package
 779                (inherit p)
 780                (version (upstream-source-version source))
 781                (source source))))))
 782
 783   (define rewrite
 784     (package-input-rewriting/spec
 785      (map (lambda (spec)
 786             (cons spec package-with-latest-upstream))
 787           specs)))
 788
 789   (lambda (obj)
 790     (if (package? obj)
 791         (rewrite obj)
 792         obj)))
 793
 794 (define %transformations
 795   ;; Transformations that can be applied to things to build.  The car is the
 796   ;; key used in the option alist, and the cdr is the transformation
 797   ;; procedure; it is called with two arguments: the store, and a list of
 798   ;; things to build.
 799   `((with-source . ,transform-package-source)
 800     (with-input  . ,transform-package-inputs)
 801     (with-graft  . ,transform-package-inputs/graft)
 802     (with-branch . ,transform-package-source-branch)
 803     (with-commit . ,transform-package-source-commit)
 804     (with-git-url . ,transform-package-source-git-url)
 805     (with-c-toolchain . ,transform-package-toolchain)
 806     (tune . ,transform-package-tuning)
 807     (with-debug-info . ,transform-package-with-debug-info)
 808     (without-tests . ,transform-package-tests)
 809     (with-patch  . ,transform-package-patches)
 810     (with-latest . ,transform-package-latest)))
 811
 812 (define (transformation-procedure key)
 813   "Return the transformation procedure associated with KEY, a symbol such as
 814 'with-source', or #f if there is none."
 815   (any (match-lambda
 816          ((k . proc)
 817           (and (eq? k key) proc)))
 818        %transformations))
 819
 820 (define (transformation-option-key? key)
 821   "Return true if KEY is an option key (as returned while parsing options with
 822 %TRANSFORMATION-OPTIONS) corresponding to a package transformation option.
 823 For example, (transformation-option-key? 'with-input) => #t."
 824   (->bool (transformation-procedure key)))
 825
 826 \f
 827 ;;;
 828 ;;; Command-line handling.
 829 ;;;
 830
 831 (define %transformation-options
 832   ;; The command-line interface to the above transformations.
 833   (let ((parser (lambda (symbol)
 834                   (lambda (opt name arg result . rest)
 835                     (apply values
 836                            (alist-cons symbol arg result)
 837                            rest)))))
 838     (list (option '("with-source") #t #f
 839                   (parser 'with-source))
 840           (option '("with-input") #t #f
 841                   (parser 'with-input))
 842           (option '("with-graft") #t #f
 843                   (parser 'with-graft))
 844           (option '("with-branch") #t #f
 845                   (parser 'with-branch))
 846           (option '("with-commit") #t #f
 847                   (parser 'with-commit))
 848           (option '("with-git-url") #t #f
 849                   (parser 'with-git-url))
 850           (option '("with-c-toolchain") #t #f
 851                   (parser 'with-c-toolchain))
 852           (option '("tune") #f #t
 853                   (lambda (opt name arg result . rest)
 854                     (define micro-architecture
 855                       (match arg
 856                         ((or #f "native")
 857                          (unless (string=? (or (assoc-ref result 'system)
 858                                                (%current-system))
 859                                            %system)
 860                            (leave (G_ "\
 861 building for ~a instead of ~a, so tuning cannot be guessed~%")
 862                                   (assoc-ref result 'system) %system))
 863
 864                          (cpu->gcc-architecture (current-cpu)))
 865                         ("generic" #f)
 866                         (_ arg)))
 867
 868                     (apply values
 869                            (if micro-architecture
 870                                (alist-cons 'tune micro-architecture
 871                                            result)
 872                                (alist-delete 'tune result))
 873                            rest)))
 874           (option '("with-debug-info") #t #f
 875                   (parser 'with-debug-info))
 876           (option '("without-tests") #t #f
 877                   (parser 'without-tests))
 878           (option '("with-patch") #t #f
 879                   (parser 'with-patch))
 880           (option '("with-latest") #t #f
 881                   (parser 'with-latest))
 882
 883           (option '("help-transform") #f #f
 884                   (lambda _
 885                     (format #t
 886                             (G_ "Available package transformation options:~%"))
 887                     (show-transformation-options-help/detailed)
 888                     (newline)
 889                     (exit 0))))))
 890
 891 (define (show-transformation-options-help/detailed)
 892   (display (G_ "
 893       --with-source=[PACKAGE=]SOURCE
 894                          use SOURCE when building the corresponding package"))
 895   (display (G_ "
 896       --with-input=PACKAGE=REPLACEMENT
 897                          replace dependency PACKAGE by REPLACEMENT"))
 898   (display (G_ "
 899       --with-graft=PACKAGE=REPLACEMENT
 900                          graft REPLACEMENT on packages that refer to PACKAGE"))
 901   (display (G_ "
 902       --with-branch=PACKAGE=BRANCH
 903                          build PACKAGE from the latest commit of BRANCH"))
 904   (display (G_ "
 905       --with-commit=PACKAGE=COMMIT
 906                          build PACKAGE from COMMIT"))
 907   (display (G_ "
 908       --with-git-url=PACKAGE=URL
 909                          build PACKAGE from the repository at URL"))
 910   (display (G_ "
 911       --with-patch=PACKAGE=FILE
 912                          add FILE to the list of patches of PACKAGE"))
 913   (display (G_ "
 914       --with-latest=PACKAGE
 915                          use the latest upstream release of PACKAGE"))
 916   (display (G_ "
 917       --with-c-toolchain=PACKAGE=TOOLCHAIN
 918                          build PACKAGE and its dependents with TOOLCHAIN"))
 919   (display (G_ "
 920       --with-debug-info=PACKAGE
 921                          build PACKAGE and preserve its debug info"))
 922   (display (G_ "
 923       --without-tests=PACKAGE
 924                          build PACKAGE without running its tests")))
 925
 926 (define (show-transformation-options-help)
 927   "Show basic help for package transformation options."
 928   (display (G_ "
 929       --help-transform   list package transformation options not shown here")))
 930
 931 (define (options->transformation opts)
 932   "Return a procedure that, when passed an object to build (package,
 933 derivation, etc.), applies the transformations specified by OPTS and returns
 934 the resulting objects.  OPTS must be a list of symbol/string pairs such as:
 935
 936   ((with-branch . \"guile-gcrypt=master\")
 937    (without-tests . \"libgcrypt\"))
 938
 939 Each symbol names a transformation and the corresponding string is an argument
 940 to that transformation."
 941   (define applicable
 942     ;; List of applicable transformations as symbol/procedure pairs in the
 943     ;; order in which they appear on the command line.
 944     (filter-map (match-lambda
 945                   ((key . value)
 946                    (match (transformation-procedure key)
 947                      (#f
 948                       #f)
 949                      (transform
 950                       ;; XXX: We used to pass TRANSFORM a list of several
 951                       ;; arguments, but we now pass only one, assuming that
 952                       ;; transform composes well.
 953                       (list key value (transform (list value)))))))
 954                 (reverse opts)))
 955
 956   (define (package-with-transformation-properties p)
 957     (package/inherit p
 958       (properties `((transformations
 959                      . ,(map (match-lambda
 960                                ((key value _)
 961                                 (cons key value)))
 962                              (reverse applicable))) ;preserve order
 963                     ,@(package-properties p)))))
 964
 965   (lambda (obj)
 966     (define (tagged-object new)
 967       (if (and (not (eq? obj new))
 968                (package? new) (not (null? applicable)))
 969           (package-with-transformation-properties new)
 970           new))
 971
 972     (tagged-object
 973      (fold (match-lambda*
 974              (((name value transform) obj)
 975               (let ((new (transform obj)))
 976                 (when (eq? new obj)
 977                   (warning (G_ "transformation '~a' had no effect on ~a~%")
 978                            name
 979                            (if (package? obj)
 980                                (package-full-name obj)
 981                                obj)))
 982                 new)))
 983            obj
 984            applicable))))
 985
 986 (define (package-transformations package)
 987   "Return the transformations applied to PACKAGE according to its properties."
 988   (match (assq-ref (package-properties package) 'transformations)
 989     (#f '())
 990     (transformations transformations)))
 991
 992 (define (manifest-entry-with-transformations entry)
 993   "Return ENTRY with an additional 'transformations' property if it's not
 994 already there."
 995   (let ((properties (manifest-entry-properties entry)))
 996     (if (assq 'transformations properties)
 997         entry
 998         (let ((item (manifest-entry-item entry)))
 999           (manifest-entry
1000             (inherit entry)
1001             (properties
1002              (match (and (package? item)
1003                          (package-transformations item))
1004                ((or #f '())
1005                 properties)
1006                (transformations
1007                 `((transformations . ,transformations)
1008                   ,@properties)))))))))