guix/packages.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2014, 2015, 2017, 2018 Mark H Weaver <mhw@netris.org>
   4 ;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
   5 ;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
   6 ;;; Copyright © 2017, 2019, 2020 Efraim Flashner <efraim@flashner.co.il>
   7 ;;; Copyright © 2019 Marius Bakke <mbakke@fastmail.com>
   8 ;;;
   9 ;;; This file is part of GNU Guix.
  10 ;;;
  11 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  12 ;;; under the terms of the GNU General Public License as published by
  13 ;;; the Free Software Foundation; either version 3 of the License, or (at
  14 ;;; your option) any later version.
  15 ;;;
  16 ;;; GNU Guix is distributed in the hope that it will be useful, but
  17 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;;; GNU General Public License for more details.
  20 ;;;
  21 ;;; You should have received a copy of the GNU General Public License
  22 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 (define-module (guix packages)
  25   #:use-module (guix utils)
  26   #:use-module (guix records)
  27   #:use-module (guix store)
  28   #:use-module (guix monads)
  29   #:use-module (guix gexp)
  30   #:use-module (guix base32)
  31   #:use-module (guix grafts)
  32   #:use-module (guix derivations)
  33   #:use-module (guix memoization)
  34   #:use-module (guix build-system)
  35   #:use-module (guix search-paths)
  36   #:use-module (guix sets)
  37   #:use-module (ice-9 match)
  38   #:use-module (ice-9 vlist)
  39   #:use-module (ice-9 regex)
  40   #:use-module (srfi srfi-1)
  41   #:use-module (srfi srfi-9 gnu)
  42   #:use-module (srfi srfi-11)
  43   #:use-module (srfi srfi-26)
  44   #:use-module (srfi srfi-34)
  45   #:use-module (srfi srfi-35)
  46   #:use-module (web uri)
  47   #:re-export (%current-system
  48                %current-target-system
  49                search-path-specification)         ;for convenience
  50   #:export (origin
  51             origin?
  52             this-origin
  53             origin-uri
  54             origin-method
  55             origin-sha256
  56             origin-file-name
  57             origin-actual-file-name
  58             origin-patches
  59             origin-patch-flags
  60             origin-patch-inputs
  61             origin-patch-guile
  62             origin-snippet
  63             origin-modules
  64             base32
  65
  66             package
  67             package?
  68             this-package
  69             package-name
  70             package-upstream-name
  71             package-version
  72             package-full-name
  73             package-source
  74             package-build-system
  75             package-arguments
  76             package-inputs
  77             package-native-inputs
  78             package-propagated-inputs
  79             package-outputs
  80             package-native-search-paths
  81             package-search-paths
  82             package-replacement
  83             package-synopsis
  84             package-description
  85             package-license
  86             package-home-page
  87             package-supported-systems
  88             package-properties
  89             package-location
  90             hidden-package
  91             hidden-package?
  92             package-superseded
  93             deprecated-package
  94             package-field-location
  95
  96             package-direct-sources
  97             package-transitive-sources
  98             package-direct-inputs
  99             package-transitive-inputs
 100             package-transitive-target-inputs
 101             package-transitive-native-inputs
 102             package-transitive-propagated-inputs
 103             package-transitive-native-search-paths
 104             package-transitive-supported-systems
 105             package-mapping
 106             package-input-rewriting
 107             package-input-rewriting/spec
 108             package-source-derivation
 109             package-derivation
 110             package-cross-derivation
 111             package-output
 112             package-grafts
 113             package-patched-vulnerabilities
 114             package-with-patches
 115             package-with-extra-patches
 116             package/inherit
 117
 118             transitive-input-references
 119
 120             %supported-systems
 121             %hurd-systems
 122             %hydra-supported-systems
 123             supported-package?
 124
 125             &package-error
 126             package-error?
 127             package-error-package
 128             &package-input-error
 129             package-input-error?
 130             package-error-invalid-input
 131             &package-cross-build-system-error
 132             package-cross-build-system-error?
 133
 134             package->bag
 135             bag->derivation
 136             bag-direct-inputs
 137             bag-transitive-inputs
 138             bag-transitive-host-inputs
 139             bag-transitive-build-inputs
 140             bag-transitive-target-inputs
 141             package-closure
 142
 143             default-guile
 144             default-guile-derivation
 145             set-guile-for-build
 146             package-file
 147             package->derivation
 148             package->cross-derivation
 149             origin->derivation))
 150
 151 ;;; Commentary:
 152 ;;;
 153 ;;; This module provides a high-level mechanism to define packages in a
 154 ;;; Guix-based distribution.
 155 ;;;
 156 ;;; Code:
 157
 158 ;; The source of a package, such as a tarball URL and fetcher---called
 159 ;; "origin" to avoid name clash with `package-source', `source', etc.
 160 (define-record-type* <origin>
 161   origin make-origin
 162   origin?
 163   this-origin
 164   (uri       origin-uri)                          ; string
 165   (method    origin-method)                       ; procedure
 166   (sha256    origin-sha256)                       ; bytevector
 167   (file-name origin-file-name (default #f))       ; optional file name
 168
 169   ;; Patches are delayed so that the 'search-patch' calls are made lazily,
 170   ;; which reduces I/O on startup and allows patch-not-found errors to be
 171   ;; gracefully handled at run time.
 172   (patches   origin-patches                       ; list of file names
 173              (default '()) (delayed))
 174
 175   (snippet   origin-snippet (default #f))         ; sexp or #f
 176   (patch-flags  origin-patch-flags                ; list of strings
 177                 (default '("-p1")))
 178
 179   ;; Patching requires Guile, GNU Patch, and a few more.  These two fields are
 180   ;; used to specify these dependencies when needed.
 181   (patch-inputs origin-patch-inputs               ; input list or #f
 182                 (default #f))
 183   (modules      origin-modules                    ; list of module names
 184                 (default '()))
 185
 186   (patch-guile origin-patch-guile                 ; package or #f
 187                (default #f)))
 188
 189 (define (print-origin origin port)
 190   "Write a concise representation of ORIGIN to PORT."
 191   (match origin
 192     (($ <origin> uri method sha256 file-name patches)
 193      (simple-format port "#<origin ~s ~a ~s ~a>"
 194                     uri (bytevector->base32-string sha256)
 195                     (force patches)
 196                     (number->string (object-address origin) 16)))))
 197
 198 (set-record-type-printer! <origin> print-origin)
 199
 200 (define-syntax base32
 201   (lambda (s)
 202     "Return the bytevector corresponding to the given Nix-base32
 203 representation."
 204     (syntax-case s ()
 205       ((_ str)
 206        (string? (syntax->datum #'str))
 207        ;; A literal string: do the conversion at expansion time.
 208        (with-syntax ((bv (nix-base32-string->bytevector
 209                           (syntax->datum #'str))))
 210          #''bv))
 211       ((_ str)
 212        #'(nix-base32-string->bytevector str)))))
 213
 214 (define (origin-actual-file-name origin)
 215   "Return the file name of ORIGIN, either its 'file-name' field or the file
 216 name of its URI."
 217   (define (uri->file-name uri)
 218     ;; Return the 'base name' of URI or URI itself, where URI is a string.
 219     (let ((path (and=> (string->uri uri) uri-path)))
 220       (if path
 221           (basename path)
 222           uri)))
 223
 224   (or (origin-file-name origin)
 225       (match (origin-uri origin)
 226         ((head . tail)
 227          (uri->file-name head))
 228         ((? string? uri)
 229          (uri->file-name uri))
 230         (else
 231          ;; git, svn, cvs, etc. reference
 232          #f))))
 233
 234 (define %supported-systems
 235   ;; This is the list of system types that are supported.  By default, we
 236   ;; expect all packages to build successfully here.
 237   '("x86_64-linux" "i686-linux" "armhf-linux" "aarch64-linux" "mips64el-linux" "i586-gnu"))
 238
 239 (define %hurd-systems
 240   ;; The GNU/Hurd systems for which support is being developed.
 241   '("i586-gnu" "i686-gnu"))
 242
 243 (define %hydra-supported-systems
 244   ;; This is the list of system types for which build machines are available.
 245   ;;
 246   ;; XXX: MIPS is unavailable in CI:
 247   ;; <https://lists.gnu.org/archive/html/guix-devel/2017-03/msg00790.html>.
 248   (fold delete %supported-systems '("mips64el-linux")))
 249
 250
 251 ;; A package.
 252 (define-record-type* <package>
 253   package make-package
 254   package?
 255   this-package
 256   (name   package-name)                   ; string
 257   (version package-version)               ; string
 258   (source package-source)                 ; <origin> instance
 259   (build-system package-build-system)     ; build system
 260   (arguments package-arguments            ; arguments for the build method
 261              (default '()) (thunked))
 262
 263   (inputs package-inputs                  ; input packages or derivations
 264           (default '()) (thunked))
 265   (propagated-inputs package-propagated-inputs    ; same, but propagated
 266                      (default '()) (thunked))
 267   (native-inputs package-native-inputs    ; native input packages/derivations
 268                  (default '()) (thunked))
 269
 270   (outputs package-outputs                ; list of strings
 271            (default '("out")))
 272
 273                                                   ; lists of
 274                                                   ; <search-path-specification>,
 275                                                   ; for native and cross
 276                                                   ; inputs
 277   (native-search-paths package-native-search-paths (default '()))
 278   (search-paths package-search-paths (default '()))
 279
 280   ;; The 'replacement' field is marked as "innate" because it never makes
 281   ;; sense to inherit a replacement as is.  See the 'package/inherit' macro.
 282   (replacement package-replacement                ; package | #f
 283                (default #f) (thunked) (innate))
 284
 285   (synopsis package-synopsis)                    ; one-line description
 286   (description package-description)              ; one or two paragraphs
 287   (license package-license)
 288   (home-page package-home-page)
 289   (supported-systems package-supported-systems    ; list of strings
 290                      (default %supported-systems))
 291
 292   (properties package-properties (default '()))   ; alist for anything else
 293
 294   (location package-location
 295             (default (and=> (current-source-location)
 296                             source-properties->location))
 297             (innate)))
 298
 299 (set-record-type-printer! <package>
 300                           (lambda (package port)
 301                             (let ((loc    (package-location package))
 302                                   (format simple-format))
 303                               (format port "#<package ~a@~a ~a~a>"
 304                                       (package-name package)
 305                                       (package-version package)
 306                                       (if loc
 307                                           (format #f "~a:~a "
 308                                                   (location-file loc)
 309                                                   (location-line loc))
 310                                           "")
 311                                       (number->string (object-address
 312                                                        package)
 313                                                       16)))))
 314
 315 (define (package-upstream-name package)
 316   "Return the upstream name of PACKAGE, which could be different from the name
 317 it has in Guix."
 318   (or (assq-ref (package-properties package) 'upstream-name)
 319       (package-name package)))
 320
 321 (define (hidden-package p)
 322   "Return a \"hidden\" version of P--i.e., one that 'fold-packages' and thus,
 323 user interfaces, ignores."
 324   (package
 325     (inherit p)
 326     (properties `((hidden? . #t)
 327                   ,@(package-properties p)))))
 328
 329 (define (hidden-package? p)
 330   "Return true if P is \"hidden\"--i.e., must not be visible to user
 331 interfaces."
 332   (assoc-ref (package-properties p) 'hidden?))
 333
 334 (define (package-superseded p)
 335   "Return the package the supersedes P, or #f if P is still current."
 336   (assoc-ref (package-properties p) 'superseded))
 337
 338 (define (deprecated-package old-name p)
 339   "Return a package called OLD-NAME and marked as superseded by P, a package
 340 object."
 341   (package
 342     (inherit p)
 343     (name old-name)
 344     (properties `((superseded . ,p)))))
 345
 346 (define (package-field-location package field)
 347   "Return the source code location of the definition of FIELD for PACKAGE, or
 348 #f if it could not be determined."
 349   (define (goto port line column)
 350     (unless (and (= (port-column port) (- column 1))
 351                  (= (port-line port) (- line 1)))
 352       (unless (eof-object? (read-char port))
 353         (goto port line column))))
 354
 355   (match (package-location package)
 356     (($ <location> file line column)
 357      (catch 'system-error
 358        (lambda ()
 359          ;; In general we want to keep relative file names for modules.
 360          (call-with-input-file (search-path %load-path file)
 361            (lambda (port)
 362              (goto port line column)
 363              (match (read port)
 364                (('package inits ...)
 365                 (let ((field (assoc field inits)))
 366                   (match field
 367                     ((_ value)
 368                      (let ((loc (and=> (source-properties value)
 369                                        source-properties->location)))
 370                        (and loc
 371                             ;; Preserve the original file name, which may be a
 372                             ;; relative file name.
 373                             (set-field loc (location-file) file))))
 374                     (_
 375                      #f))))
 376                (_
 377                 #f)))))
 378        (lambda _
 379          #f)))
 380     (_ #f)))
 381
 382
 383 ;; Error conditions.
 384
 385 (define-condition-type &package-error &error
 386   package-error?
 387   (package package-error-package))
 388
 389 (define-condition-type &package-input-error &package-error
 390   package-input-error?
 391   (input package-error-invalid-input))
 392
 393 (define-condition-type &package-cross-build-system-error &package-error
 394   package-cross-build-system-error?)
 395
 396 (define* (package-full-name package #:optional (delimiter "@"))
 397   "Return the full name of PACKAGE--i.e., `NAME@VERSION'.  By specifying
 398 DELIMITER (a string), you can customize what will appear between the name and
 399 the version.  By default, DELIMITER is \"@\"."
 400   (string-append (package-name package) delimiter (package-version package)))
 401
 402 (define (patch-file-name patch)
 403   "Return the basename of PATCH's file name, or #f if the file name could not
 404 be determined."
 405   (match patch
 406     ((? string?)
 407      (basename patch))
 408     ((? origin?)
 409      (and=> (origin-actual-file-name patch) basename))))
 410
 411 (define %vulnerability-regexp
 412   ;; Regexp matching a CVE identifier in patch file names.
 413   (make-regexp "CVE-[0-9]{4}-[0-9]+"))
 414
 415 (define (package-patched-vulnerabilities package)
 416   "Return the list of patched vulnerabilities of PACKAGE as a list of CVE
 417 identifiers.  The result is inferred from the file names of patches."
 418   (define (patch-vulnerabilities patch)
 419     (map (cut match:substring <> 0)
 420          (list-matches %vulnerability-regexp patch)))
 421
 422   (let ((patches (filter-map patch-file-name
 423                              (or (and=> (package-source package)
 424                                         origin-patches)
 425                                  '()))))
 426     (append-map patch-vulnerabilities patches)))
 427
 428 (define (%standard-patch-inputs)
 429   (let* ((canonical (module-ref (resolve-interface '(gnu packages base))
 430                                 'canonical-package))
 431          (ref       (lambda (module var)
 432                       (canonical
 433                        (module-ref (resolve-interface module) var)))))
 434     `(("tar"   ,(ref '(gnu packages base) 'tar))
 435       ("xz"    ,(ref '(gnu packages compression) 'xz))
 436       ("bzip2" ,(ref '(gnu packages compression) 'bzip2))
 437       ("gzip"  ,(ref '(gnu packages compression) 'gzip))
 438       ("lzip"  ,(ref '(gnu packages compression) 'lzip))
 439       ("unzip" ,(ref '(gnu packages compression) 'unzip))
 440       ("patch" ,(ref '(gnu packages base) 'patch))
 441       ("locales" ,(ref '(gnu packages base) 'glibc-utf8-locales)))))
 442
 443 (define (default-guile)
 444   "Return the default Guile package used to run the build code of
 445 derivations."
 446   (let ((distro (resolve-interface '(gnu packages commencement))))
 447     (module-ref distro 'guile-final)))
 448
 449 (define (guile-for-grafts)
 450   "Return the Guile package used to build grafting derivations."
 451   ;; Guile 2.2 would not work due to <https://bugs.gnu.org/28211> when
 452   ;; grafting packages.
 453   (let ((distro (resolve-interface '(gnu packages guile))))
 454     (module-ref distro 'guile-2.0)))
 455
 456 (define* (default-guile-derivation #:optional (system (%current-system)))
 457   "Return the derivation for SYSTEM of the default Guile package used to run
 458 the build code of derivation."
 459   (package->derivation (default-guile) system
 460                        #:graft? #f))
 461
 462 (define* (patch-and-repack source patches
 463                            #:key
 464                            inputs
 465                            (snippet #f)
 466                            (flags '("-p1"))
 467                            (modules '())
 468                            (guile-for-build (%guile-for-build))
 469                            (system (%current-system)))
 470   "Unpack SOURCE (a derivation or store path), apply all of PATCHES, and
 471 repack the tarball using the tools listed in INPUTS.  When SNIPPET is true,
 472 it must be an s-expression that will run from within the directory where
 473 SOURCE was unpacked, after all of PATCHES have been applied.  MODULES
 474 specifies modules in scope when evaluating SNIPPET."
 475   (define source-file-name
 476     ;; SOURCE is usually a derivation, but it could be a store file.
 477     (if (derivation? source)
 478         (derivation->output-path source)
 479         source))
 480
 481   (define lookup-input
 482     ;; The default value of the 'patch-inputs' field, and thus INPUTS is #f,
 483     ;; so deal with that.
 484     (let ((inputs (or inputs (%standard-patch-inputs))))
 485       (lambda (name)
 486         (match (assoc-ref inputs name)
 487           ((package) package)
 488           (#f        #f)))))
 489
 490   (define decompression-type
 491     (cond ((string-suffix? "gz" source-file-name)  "gzip")
 492           ((string-suffix? "Z" source-file-name)  "gzip")
 493           ((string-suffix? "bz2" source-file-name) "bzip2")
 494           ((string-suffix? "lz" source-file-name)  "lzip")
 495           ((string-suffix? "zip" source-file-name) "unzip")
 496           (else "xz")))
 497
 498   (define original-file-name
 499     ;; Remove the store prefix plus the slash, hash, and hyphen.
 500     (let* ((sans (string-drop source-file-name
 501                               (+ (string-length (%store-prefix)) 1)))
 502            (dash (string-index sans #\-)))
 503       (string-drop sans (+ 1 dash))))
 504
 505   (define (numeric-extension? file-name)
 506     ;; Return true if FILE-NAME ends with digits.
 507     (and=> (file-extension file-name)
 508            (cut string-every char-set:hex-digit <>)))
 509
 510   (define (checkout? directory)
 511     ;; Return true if DIRECTORY is a checkout (git, svn, etc).
 512     (string-suffix? "-checkout" directory))
 513
 514   (define (tarxz-name file-name)
 515     ;; Return a '.tar.xz' file name based on FILE-NAME.
 516     (let ((base (cond ((numeric-extension? file-name)
 517                        original-file-name)
 518                       ((checkout? file-name)
 519                        (string-drop-right file-name 9))
 520                       (else (file-sans-extension file-name)))))
 521       (string-append base
 522                      (if (equal? (file-extension base) "tar")
 523                          ".xz"
 524                          ".tar.xz"))))
 525
 526   (define instantiate-patch
 527     (match-lambda
 528       ((? string? patch)                          ;deprecated
 529        (interned-file patch #:recursive? #t))
 530       ((? struct? patch)                          ;origin, local-file, etc.
 531        (lower-object patch system))))
 532
 533   (mlet %store-monad ((tar ->     (lookup-input "tar"))
 534                       (xz ->      (lookup-input "xz"))
 535                       (patch ->   (lookup-input "patch"))
 536                       (locales -> (lookup-input "locales"))
 537                       (decomp ->  (lookup-input decompression-type))
 538                       (patches    (sequence %store-monad
 539                                             (map instantiate-patch patches))))
 540     (define build
 541       (with-imported-modules '((guix build utils))
 542         #~(begin
 543             (use-modules (ice-9 ftw)
 544                          (srfi srfi-1)
 545                          (guix build utils))
 546
 547             ;; The --sort option was added to GNU tar in version 1.28, released
 548             ;; 2014-07-28.  During bootstrap we must cope with older versions.
 549             (define tar-supports-sort?
 550               (zero? (system* (string-append #+tar "/bin/tar")
 551                               "cf" "/dev/null" "--files-from=/dev/null"
 552                               "--sort=name")))
 553
 554             (define (apply-patch patch)
 555               (format (current-error-port) "applying '~a'...~%" patch)
 556
 557               ;; Use '--force' so that patches that do not apply perfectly are
 558               ;; rejected.  Use '--no-backup-if-mismatch' to prevent making
 559               ;; "*.orig" file if a patch is applied with offset.
 560               (invoke (string-append #+patch "/bin/patch")
 561                       "--force" "--no-backup-if-mismatch"
 562                       #+@flags "--input" patch))
 563
 564             (define (first-file directory)
 565               ;; Return the name of the first file in DIRECTORY.
 566               (car (scandir directory
 567                             (lambda (name)
 568                               (not (member name '("." "..")))))))
 569
 570             ;; Encoding/decoding errors shouldn't be silent.
 571             (fluid-set! %default-port-conversion-strategy 'error)
 572
 573             (when #+locales
 574               ;; First of all, install a UTF-8 locale so that UTF-8 file names
 575               ;; are correctly interpreted.  During bootstrap, LOCALES is #f.
 576               (setenv "LOCPATH"
 577                       (string-append #+locales "/lib/locale/"
 578                                      #+(and locales
 579                                             (version-major+minor
 580                                              (package-version locales)))))
 581               (setlocale LC_ALL "en_US.utf8"))
 582
 583             (setenv "PATH" (string-append #+xz "/bin" ":"
 584                                           #+decomp "/bin"))
 585
 586             ;; SOURCE may be either a directory or a tarball.
 587             (if (file-is-directory? #+source)
 588                 (let* ((store     (%store-directory))
 589                        (len       (+ 1 (string-length store)))
 590                        (base      (string-drop #+source len))
 591                        (dash      (string-index base #\-))
 592                        (directory (string-drop base (+ 1 dash))))
 593                   (mkdir directory)
 594                   (copy-recursively #+source directory))
 595                 #+(if (string=? decompression-type "unzip")
 596                       #~(invoke "unzip" #+source)
 597                       #~(invoke (string-append #+tar "/bin/tar")
 598                                 "xvf" #+source)))
 599
 600             (let ((directory (first-file ".")))
 601               (format (current-error-port)
 602                       "source is under '~a'~%" directory)
 603               (chdir directory)
 604
 605               (for-each apply-patch '#+patches)
 606
 607               (let ((result #+(if snippet
 608                                   #~(let ((module (make-fresh-user-module)))
 609                                       (module-use-interfaces!
 610                                        module
 611                                        (map resolve-interface '#+modules))
 612                                       ((@ (system base compile) compile)
 613                                        '#+snippet
 614                                        #:to 'value
 615                                        #:opts %auto-compilation-options
 616                                        #:env module))
 617                                   #~#t)))
 618                 ;; Issue a warning unless the result is #t.
 619                 (unless (eqv? result #t)
 620                   (format (current-error-port) "\
 621 ## WARNING: the snippet returned `~s'.  Return values other than #t
 622 ## are deprecated.  Please migrate this package so that its snippet
 623 ## reports errors by raising an exception, and otherwise returns #t.~%"
 624                           result))
 625                 (unless result
 626                   (error "snippet returned false")))
 627
 628               (chdir "..")
 629
 630               (unless tar-supports-sort?
 631                 (call-with-output-file ".file_list"
 632                   (lambda (port)
 633                     (for-each (lambda (name)
 634                                 (format port "~a~%" name))
 635                               (find-files directory
 636                                           #:directories? #t
 637                                           #:fail-on-error? #t)))))
 638               (apply invoke
 639                      (string-append #+tar "/bin/tar")
 640                      "cvfa" #$output
 641                      ;; Avoid non-determinism in the archive.  Set the mtime
 642                      ;; to 1 as is the case in the store (software like gzip
 643                      ;; behaves differently when it stumbles upon mtime = 0).
 644                      "--mtime=@1"
 645                      "--owner=root:0"
 646                      "--group=root:0"
 647                      (if tar-supports-sort?
 648                          `("--sort=name"
 649                            ,directory)
 650                          '("--no-recursion"
 651                            "--files-from=.file_list")))))))
 652
 653     (let ((name (tarxz-name original-file-name)))
 654       (gexp->derivation name build
 655                         #:graft? #f
 656                         #:system system
 657                         #:guile-for-build guile-for-build
 658                         #:properties `((type . origin)
 659                                        (patches . ,(length patches)))))))
 660
 661 (define (package-with-patches original patches)
 662   "Return package ORIGINAL with PATCHES applied."
 663   (package (inherit original)
 664            (source (origin (inherit (package-source original))
 665                            (patches patches)))))
 666
 667 (define (package-with-extra-patches original patches)
 668   "Return package ORIGINAL with all PATCHES appended to its list of patches."
 669   (package-with-patches original
 670                         (append (origin-patches (package-source original))
 671                                 patches)))
 672
 673 (define (transitive-inputs inputs)
 674   "Return the closure of INPUTS when considering the 'propagated-inputs'
 675 edges.  Omit duplicate inputs, except for those already present in INPUTS
 676 itself.
 677
 678 This is implemented as a breadth-first traversal such that INPUTS is
 679 preserved, and only duplicate propagated inputs are removed."
 680   (define (seen? seen item outputs)
 681     ;; FIXME: We're using pointer identity here, which is extremely sensitive
 682     ;; to memoization in package-producing procedures; see
 683     ;; <https://bugs.gnu.org/30155>.
 684     (match (vhash-assq item seen)
 685       ((_ . o) (equal? o outputs))
 686       (_       #f)))
 687
 688   (let loop ((inputs     inputs)
 689              (result     '())
 690              (propagated '())
 691              (first?     #t)
 692              (seen       vlist-null))
 693     (match inputs
 694       (()
 695        (if (null? propagated)
 696            (reverse result)
 697            (loop (reverse (concatenate propagated)) result '() #f seen)))
 698       (((and input (label (? package? package) outputs ...)) rest ...)
 699        (if (and (not first?) (seen? seen package outputs))
 700            (loop rest result propagated first? seen)
 701            (loop rest
 702                  (cons input result)
 703                  (cons (package-propagated-inputs package) propagated)
 704                  first?
 705                  (vhash-consq package outputs seen))))
 706       ((input rest ...)
 707        (loop rest (cons input result) propagated first? seen)))))
 708
 709 (define (package-direct-sources package)
 710   "Return all source origins associated with PACKAGE; including origins in
 711 PACKAGE's inputs."
 712   `(,@(or (and=> (package-source package) list) '())
 713     ,@(filter-map (match-lambda
 714                    ((_ (? origin? orig) _ ...)
 715                     orig)
 716                    (_ #f))
 717                   (package-direct-inputs package))))
 718
 719 (define (package-transitive-sources package)
 720   "Return PACKAGE's direct sources, and their direct sources, recursively."
 721   (delete-duplicates
 722    (concatenate (filter-map (match-lambda
 723                              ((_ (? origin? orig) _ ...)
 724                               (list orig))
 725                              ((_ (? package? p) _ ...)
 726                               (package-direct-sources p))
 727                              (_ #f))
 728                             (bag-transitive-inputs
 729                              (package->bag package))))))
 730
 731 (define (package-direct-inputs package)
 732   "Return all the direct inputs of PACKAGE---i.e, its direct inputs along
 733 with their propagated inputs."
 734   (append (package-native-inputs package)
 735           (package-inputs package)
 736           (package-propagated-inputs package)))
 737
 738 (define (package-transitive-inputs package)
 739   "Return the transitive inputs of PACKAGE---i.e., its direct inputs along
 740 with their propagated inputs, recursively."
 741   (transitive-inputs (package-direct-inputs package)))
 742
 743 (define (package-transitive-target-inputs package)
 744   "Return the transitive target inputs of PACKAGE---i.e., its direct inputs
 745 along with their propagated inputs, recursively.  This only includes inputs
 746 for the target system, and not native inputs."
 747   (transitive-inputs (append (package-inputs package)
 748                              (package-propagated-inputs package))))
 749
 750 (define (package-transitive-native-inputs package)
 751   "Return the transitive native inputs of PACKAGE---i.e., its direct inputs
 752 along with their propagated inputs, recursively.  This only includes inputs
 753 for the host system (\"native inputs\"), and not target inputs."
 754   (transitive-inputs (package-native-inputs package)))
 755
 756 (define (package-transitive-propagated-inputs package)
 757   "Return the propagated inputs of PACKAGE, and their propagated inputs,
 758 recursively."
 759   (transitive-inputs (package-propagated-inputs package)))
 760
 761 (define (package-transitive-native-search-paths package)
 762   "Return the list of search paths for PACKAGE and its propagated inputs,
 763 recursively."
 764   (append (package-native-search-paths package)
 765           (append-map (match-lambda
 766                         ((label (? package? p) _ ...)
 767                          (package-native-search-paths p))
 768                         (_
 769                          '()))
 770                       (package-transitive-propagated-inputs package))))
 771
 772 (define (transitive-input-references alist inputs)
 773   "Return a list of (assoc-ref ALIST <label>) for each (<label> <package> . _)
 774 in INPUTS and their transitive propagated inputs."
 775   (define label
 776     (match-lambda
 777       ((label . _)
 778        label)))
 779
 780   (map (lambda (input)
 781          `(assoc-ref ,alist ,(label input)))
 782        (transitive-inputs inputs)))
 783
 784 (define package-transitive-supported-systems
 785   (let ()
 786     (define supported-systems
 787       (mlambda (package system)
 788         (parameterize ((%current-system system))
 789           (fold (lambda (input systems)
 790                   (match input
 791                     ((label (? package? package) . _)
 792                      (lset-intersection string=? systems
 793                                         (supported-systems package system)))
 794                     (_
 795                      systems)))
 796                 (package-supported-systems package)
 797                 (bag-direct-inputs (package->bag package))))))
 798
 799     (lambda* (package #:optional (system (%current-system)))
 800       "Return the intersection of the systems supported by PACKAGE and those
 801 supported by its dependencies."
 802       (supported-systems package system))))
 803
 804 (define* (supported-package? package #:optional (system (%current-system)))
 805   "Return true if PACKAGE is supported on SYSTEM--i.e., if PACKAGE and all its
 806 dependencies are known to build on SYSTEM."
 807   (member system (package-transitive-supported-systems package system)))
 808
 809 (define (bag-direct-inputs bag)
 810   "Same as 'package-direct-inputs', but applied to a bag."
 811   (append (bag-build-inputs bag)
 812           (bag-host-inputs bag)
 813           (bag-target-inputs bag)))
 814
 815 (define (bag-transitive-inputs bag)
 816   "Same as 'package-transitive-inputs', but applied to a bag."
 817   (transitive-inputs (bag-direct-inputs bag)))
 818
 819 (define (bag-transitive-build-inputs bag)
 820   "Same as 'package-transitive-native-inputs', but applied to a bag."
 821   (transitive-inputs (bag-build-inputs bag)))
 822
 823 (define (bag-transitive-host-inputs bag)
 824   "Same as 'package-transitive-target-inputs', but applied to a bag."
 825   (parameterize ((%current-target-system (bag-target bag)))
 826     (transitive-inputs (bag-host-inputs bag))))
 827
 828 (define (bag-transitive-target-inputs bag)
 829   "Return the \"target inputs\" of BAG, recursively."
 830   (transitive-inputs (bag-target-inputs bag)))
 831
 832 (define* (package-closure packages #:key (system (%current-system)))
 833   "Return the closure of PACKAGES on SYSTEM--i.e., PACKAGES and the list of
 834 packages they depend on, recursively."
 835   (let loop ((packages packages)
 836              (visited  vlist-null)
 837              (closure  (list->setq packages)))
 838     (match packages
 839       (()
 840        (set->list closure))
 841       ((package . rest)
 842        (if (vhash-assq package visited)
 843            (loop rest visited closure)
 844            (let* ((bag          (package->bag package system))
 845                   (dependencies (filter-map (match-lambda
 846                                               ((label (? package? package) . _)
 847                                                package)
 848                                               (_ #f))
 849                                             (bag-direct-inputs bag))))
 850              (loop (append dependencies rest)
 851                    (vhash-consq package #t visited)
 852                    (fold set-insert closure dependencies))))))))
 853
 854 (define* (package-mapping proc #:optional (cut? (const #f)))
 855   "Return a procedure that, given a package, applies PROC to all the packages
 856 depended on and returns the resulting package.  The procedure stops recursion
 857 when CUT? returns true for a given package."
 858   (define (rewrite input)
 859     (match input
 860       ((label (? package? package) outputs ...)
 861        (let ((proc (if (cut? package) proc replace)))
 862          (cons* label (proc package) outputs)))
 863       (_
 864        input)))
 865
 866   (define replace
 867     (mlambdaq (p)
 868       ;; Return a variant of P with PROC applied to P and its explicit
 869       ;; dependencies, recursively.  Memoize the transformations.  Failing to
 870       ;; do that, we would build a huge object graph with lots of duplicates,
 871       ;; which in turns prevents us from benefiting from memoization in
 872       ;; 'package-derivation'.
 873       (let ((p (proc p)))
 874         (package
 875           (inherit p)
 876           (location (package-location p))
 877           (inputs (map rewrite (package-inputs p)))
 878           (native-inputs (map rewrite (package-native-inputs p)))
 879           (propagated-inputs (map rewrite (package-propagated-inputs p)))
 880           (replacement (and=> (package-replacement p) proc))))))
 881
 882   replace)
 883
 884 (define* (package-input-rewriting replacements
 885                                   #:optional (rewrite-name identity))
 886   "Return a procedure that, when passed a package, replaces its direct and
 887 indirect dependencies (but not its implicit inputs) according to REPLACEMENTS.
 888 REPLACEMENTS is a list of package pairs; the first element of each pair is the
 889 package to replace, and the second one is the replacement.
 890
 891 Optionally, REWRITE-NAME is a one-argument procedure that takes the name of a
 892 package and returns its new name after rewrite."
 893   (define (rewrite p)
 894     (match (assq-ref replacements p)
 895       (#f  (package
 896              (inherit p)
 897              (name (rewrite-name (package-name p)))))
 898       (new new)))
 899
 900   (package-mapping rewrite (cut assq <> replacements)))
 901
 902 (define (package-input-rewriting/spec replacements)
 903   "Return a procedure that, given a package, applies the given REPLACEMENTS to
 904 all the package graph (excluding implicit inputs).  REPLACEMENTS is a list of
 905 spec/procedures pair; each spec is a package specification such as \"gcc\" or
 906 \"guile@2\", and each procedure takes a matching package and returns a
 907 replacement for that package."
 908   (define table
 909     (fold (lambda (replacement table)
 910             (match replacement
 911               ((spec . proc)
 912                (let-values (((name version)
 913                              (package-name->name+version spec)))
 914                  (vhash-cons name (list version proc) table)))))
 915           vlist-null
 916           replacements))
 917
 918   (define (find-replacement package)
 919     (vhash-fold* (lambda (item proc)
 920                    (or proc
 921                        (match item
 922                          ((#f proc)
 923                           proc)
 924                          ((version proc)
 925                           (and (version-prefix? version
 926                                                 (package-version package))
 927                                proc)))))
 928                  #f
 929                  (package-name package)
 930                  table))
 931
 932   (define (rewrite package)
 933     (match (find-replacement package)
 934       (#f package)
 935       (proc (proc package))))
 936
 937   (package-mapping rewrite find-replacement))
 938
 939 (define-syntax-rule (package/inherit p overrides ...)
 940   "Like (package (inherit P) OVERRIDES ...), except that the same
 941 transformation is done to the package replacement, if any.  P must be a bare
 942 identifier, and will be bound to either P or its replacement when evaluating
 943 OVERRIDES."
 944   (let loop ((p p))
 945     (package (inherit p)
 946       overrides ...
 947       (replacement (and=> (package-replacement p) loop)))))
 948
 949 \f
 950 ;;;
 951 ;;; Package derivations.
 952 ;;;
 953
 954 (define %derivation-cache
 955   ;; Package to derivation-path mapping.
 956   (make-weak-key-hash-table 100))
 957
 958 (define (cache! cache package system thunk)
 959   "Memoize in CACHE the return values of THUNK as the derivation of PACKAGE on
 960 SYSTEM."
 961   ;; FIXME: This memoization should be associated with the open store, because
 962   ;; otherwise it breaks when switching to a different store.
 963   (let ((result (thunk)))
 964     ;; Use `hashq-set!' instead of `hash-set!' because `hash' returns the
 965     ;; same value for all structs (as of Guile 2.0.6), and because pointer
 966     ;; equality is sufficient in practice.
 967     (hashq-set! cache package
 968                 `((,system . ,result)
 969                   ,@(or (hashq-ref cache package) '())))
 970     result))
 971
 972 (define-syntax cached
 973   (syntax-rules (=>)
 974     "Memoize the result of BODY for the arguments PACKAGE and SYSTEM.
 975 Return the cached result when available."
 976     ((_ (=> cache) package system body ...)
 977      (let ((thunk (lambda () body ...))
 978            (key   system))
 979        (match (hashq-ref cache package)
 980          ((alist (... ...))
 981           (match (assoc-ref alist key)
 982             (#f (cache! cache package key thunk))
 983             (value value)))
 984          (#f
 985           (cache! cache package key thunk)))))
 986     ((_ package system body ...)
 987      (cached (=> %derivation-cache) package system body ...))))
 988
 989 (define* (expand-input store package input system #:optional cross-system)
 990   "Expand INPUT, an input tuple, such that it contains only references to
 991 derivation paths or store paths.  PACKAGE is only used to provide contextual
 992 information in exceptions."
 993   (define (intern file)
 994     ;; Add FILE to the store.  Set the `recursive?' bit to #t, so that
 995     ;; file permissions are preserved.
 996     (add-to-store store (basename file) #t "sha256" file))
 997
 998   (define derivation
 999     (if cross-system
1000         (cut package-cross-derivation store <> cross-system system
1001              #:graft? #f)
1002         (cut package-derivation store <> system #:graft? #f)))
1003
1004   (match input
1005     (((? string? name) (? package? package))
1006      (list name (derivation package)))
1007     (((? string? name) (? package? package)
1008       (? string? sub-drv))
1009      (list name (derivation package)
1010            sub-drv))
1011     (((? string? name)
1012       (and (? string?) (? derivation-path?) drv))
1013      (list name drv))
1014     (((? string? name)
1015       (and (? string?) (? file-exists? file)))
1016      ;; Add FILE to the store.  When FILE is in the sub-directory of a
1017      ;; store path, it needs to be added anyway, so it can be used as a
1018      ;; source.
1019      (list name (intern file)))
1020     (((? string? name) (? struct? source))
1021      ;; 'package-source-derivation' calls 'lower-object', which can throw
1022      ;; '&gexp-input-error'.  However '&gexp-input-error' lacks source
1023      ;; location info, so we catch and rethrow here (XXX: not optimal
1024      ;; performance-wise).
1025      (guard (c ((gexp-input-error? c)
1026                 (raise (condition
1027                         (&package-input-error
1028                          (package package)
1029                          (input   (gexp-error-invalid-input c)))))))
1030        (list name (package-source-derivation store source system))))
1031     (x
1032      (raise (condition (&package-input-error
1033                         (package package)
1034                         (input   x)))))))
1035
1036 (define %bag-cache
1037   ;; 'eq?' cache mapping packages to system+target+graft?-dependent bags.
1038   ;; It significantly speeds things up when doing repeated calls to
1039   ;; 'package->bag' as is the case when building a profile.
1040   (make-weak-key-hash-table 200))
1041
1042 (define* (package->bag package #:optional
1043                        (system (%current-system))
1044                        (target (%current-target-system))
1045                        #:key (graft? (%graft?)))
1046   "Compile PACKAGE into a bag for SYSTEM, possibly cross-compiled to TARGET,
1047 and return it."
1048   (let ((package (or (and graft? (package-replacement package))
1049                      package)))
1050     (cached (=> %bag-cache)
1051             package (list system target)
1052             ;; Bind %CURRENT-SYSTEM and %CURRENT-TARGET-SYSTEM so that thunked
1053             ;; field values can refer to it.
1054             (parameterize ((%current-system system)
1055                            (%current-target-system target))
1056               (match package
1057                 ((and self
1058                       ($ <package> name version source build-system
1059                                    args inputs propagated-inputs native-inputs
1060                                    outputs))
1061                  ;; Even though we prefer to use "@" to separate the package
1062                  ;; name from the package version in various user-facing parts
1063                  ;; of Guix, checkStoreName (in nix/libstore/store-api.cc)
1064                  ;; prohibits the use of "@", so use "-" instead.
1065                  (or (make-bag build-system (string-append name "-" version)
1066                                #:system system
1067                                #:target target
1068                                #:source source
1069                                #:inputs (append (inputs self)
1070                                                 (propagated-inputs self))
1071                                #:outputs outputs
1072                                #:native-inputs (native-inputs self)
1073                                #:arguments (args self))
1074                      (raise (if target
1075                                 (condition
1076                                  (&package-cross-build-system-error
1077                                   (package package)))
1078                                 (condition
1079                                  (&package-error
1080                                   (package package))))))))))))
1081
1082 (define %graft-cache
1083   ;; 'eq?' cache mapping package objects to a graft corresponding to their
1084   ;; replacement package.
1085   (make-weak-key-hash-table 200))
1086
1087 (define (input-graft store system)
1088   "Return a procedure that, given a package with a graft, returns a graft, and
1089 #f otherwise."
1090   (match-lambda
1091     ((? package? package)
1092      (let ((replacement (package-replacement package)))
1093        (and replacement
1094             (cached (=> %graft-cache) package system
1095                     (let ((orig (package-derivation store package system
1096                                                     #:graft? #f))
1097                           (new  (package-derivation store replacement system
1098                                                     #:graft? #t)))
1099                       (graft
1100                         (origin orig)
1101                         (replacement new)))))))
1102     (x
1103      #f)))
1104
1105 (define (input-cross-graft store target system)
1106   "Same as 'input-graft', but for cross-compilation inputs."
1107   (match-lambda
1108     ((? package? package)
1109     (let ((replacement (package-replacement package)))
1110       (and replacement
1111            (let ((orig (package-cross-derivation store package target system
1112                                                  #:graft? #f))
1113                  (new  (package-cross-derivation store replacement
1114                                                  target system
1115                                                  #:graft? #t)))
1116              (graft
1117                (origin orig)
1118                (replacement new))))))
1119    (_
1120     #f)))
1121
1122 (define* (fold-bag-dependencies proc seed bag
1123                                 #:key (native? #t))
1124   "Fold PROC over the packages BAG depends on.  Each package is visited only
1125 once, in depth-first order.  If NATIVE? is true, restrict to native
1126 dependencies; otherwise, restrict to target dependencies."
1127   (define bag-direct-inputs*
1128     (if native?
1129         (lambda (bag)
1130           (append (bag-build-inputs bag)
1131                   (bag-target-inputs bag)
1132                   (if (bag-target bag)
1133                       '()
1134                       (bag-host-inputs bag))))
1135         bag-host-inputs))
1136
1137   (define nodes
1138     (match (bag-direct-inputs* bag)
1139       (((labels things _ ...) ...)
1140        things)))
1141
1142   (let loop ((nodes nodes)
1143              (result seed)
1144              (visited (setq)))
1145     (match nodes
1146       (()
1147        result)
1148       (((? package? head) . tail)
1149        (if (set-contains? visited head)
1150            (loop tail result visited)
1151            (let ((inputs (bag-direct-inputs* (package->bag head))))
1152              (loop (match inputs
1153                      (((labels things _ ...) ...)
1154                       (append things tail)))
1155                    (proc head result)
1156                    (set-insert head visited)))))
1157       ((head . tail)
1158        (loop tail result visited)))))
1159
1160 (define* (bag-grafts store bag)
1161   "Return the list of grafts potentially applicable to BAG.  Potentially
1162 applicable grafts are collected by looking at direct or indirect dependencies
1163 of BAG that have a 'replacement'.  Whether a graft is actually applicable
1164 depends on whether the outputs of BAG depend on the items the grafts refer
1165 to (see 'graft-derivation'.)"
1166   (define system (bag-system bag))
1167   (define target (bag-target bag))
1168
1169   (define native-grafts
1170     (let ((->graft (input-graft store system)))
1171       (fold-bag-dependencies (lambda (package grafts)
1172                                (match (->graft package)
1173                                  (#f    grafts)
1174                                  (graft (cons graft grafts))))
1175                              '()
1176                              bag)))
1177
1178   (define target-grafts
1179     (if target
1180         (let ((->graft (input-cross-graft store target system)))
1181           (fold-bag-dependencies (lambda (package grafts)
1182                                    (match (->graft package)
1183                                      (#f    grafts)
1184                                      (graft (cons graft grafts))))
1185                                  '()
1186                                  bag
1187                                  #:native? #f))
1188         '()))
1189
1190   ;; We can end up with several identical grafts if we stumble upon packages
1191   ;; that are not 'eq?' but map to the same derivation (this can happen when
1192   ;; using things like 'package-with-explicit-inputs'.)  Hence the
1193   ;; 'delete-duplicates' call.
1194   (delete-duplicates
1195    (append native-grafts target-grafts)))
1196
1197 (define* (package-grafts store package
1198                          #:optional (system (%current-system))
1199                          #:key target)
1200   "Return the list of grafts applicable to PACKAGE as built for SYSTEM and
1201 TARGET."
1202   (let* ((package (or (package-replacement package) package))
1203          (bag     (package->bag package system target)))
1204     (bag-grafts store bag)))
1205
1206 (define* (bag->derivation store bag
1207                           #:optional context)
1208   "Return the derivation to build BAG for SYSTEM.  Optionally, CONTEXT can be
1209 a package object describing the context in which the call occurs, for improved
1210 error reporting."
1211   (if (bag-target bag)
1212       (bag->cross-derivation store bag)
1213       (let* ((system     (bag-system bag))
1214              (inputs     (bag-transitive-inputs bag))
1215              (input-drvs (map (cut expand-input store context <> system)
1216                               inputs))
1217              (paths      (delete-duplicates
1218                           (append-map (match-lambda
1219                                        ((_ (? package? p) _ ...)
1220                                         (package-native-search-paths
1221                                          p))
1222                                        (_ '()))
1223                                       inputs))))
1224
1225         (apply (bag-build bag)
1226                store (bag-name bag) input-drvs
1227                #:search-paths paths
1228                #:outputs (bag-outputs bag) #:system system
1229                (bag-arguments bag)))))
1230
1231 (define* (bag->cross-derivation store bag
1232                                 #:optional context)
1233   "Return the derivation to build BAG, which is actually a cross build.
1234 Optionally, CONTEXT can be a package object denoting the context of the call.
1235 This is an internal procedure."
1236   (let* ((system      (bag-system bag))
1237          (target      (bag-target bag))
1238          (host        (bag-transitive-host-inputs bag))
1239          (host-drvs   (map (cut expand-input store context <> system target)
1240                            host))
1241          (target*     (bag-transitive-target-inputs bag))
1242          (target-drvs (map (cut expand-input store context <> system)
1243                            target*))
1244          (build       (bag-transitive-build-inputs bag))
1245          (build-drvs  (map (cut expand-input store context <> system)
1246                            build))
1247          (all         (append build target* host))
1248          (paths       (delete-duplicates
1249                        (append-map (match-lambda
1250                                     ((_ (? package? p) _ ...)
1251                                      (package-search-paths p))
1252                                     (_ '()))
1253                                    all)))
1254          (npaths      (delete-duplicates
1255                        (append-map (match-lambda
1256                                     ((_ (? package? p) _ ...)
1257                                      (package-native-search-paths
1258                                       p))
1259                                     (_ '()))
1260                                    all))))
1261
1262     (apply (bag-build bag)
1263            store (bag-name bag)
1264            #:native-drvs build-drvs
1265            #:target-drvs (append host-drvs target-drvs)
1266            #:search-paths paths
1267            #:native-search-paths npaths
1268            #:outputs (bag-outputs bag)
1269            #:system system #:target target
1270            (bag-arguments bag))))
1271
1272 (define* (package-derivation store package
1273                              #:optional (system (%current-system))
1274                              #:key (graft? (%graft?)))
1275   "Return the <derivation> object of PACKAGE for SYSTEM."
1276
1277   ;; Compute the derivation and cache the result.  Caching is important
1278   ;; because some derivations, such as the implicit inputs of the GNU build
1279   ;; system, will be queried many, many times in a row.
1280   (cached package (cons system graft?)
1281           (let* ((bag (package->bag package system #f #:graft? graft?))
1282                  (drv (bag->derivation store bag package)))
1283             (if graft?
1284                 (match (bag-grafts store bag)
1285                   (()
1286                    drv)
1287                   (grafts
1288                    (let ((guile (package-derivation store (guile-for-grafts)
1289                                                     system #:graft? #f)))
1290                      ;; TODO: As an optimization, we can simply graft the tip
1291                      ;; of the derivation graph since 'graft-derivation'
1292                      ;; recurses anyway.
1293                      (graft-derivation store drv grafts
1294                                        #:system system
1295                                        #:guile guile))))
1296                 drv))))
1297
1298 (define* (package-cross-derivation store package target
1299                                    #:optional (system (%current-system))
1300                                    #:key (graft? (%graft?)))
1301   "Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix
1302 system identifying string)."
1303   (cached package (list system target graft?)
1304           (let* ((bag (package->bag package system target #:graft? graft?))
1305                  (drv (bag->derivation store bag package)))
1306             (if graft?
1307                 (match (bag-grafts store bag)
1308                   (()
1309                    drv)
1310                   (grafts
1311                    (graft-derivation store drv grafts
1312                                      #:system system
1313                                      #:guile
1314                                      (package-derivation store (guile-for-grafts)
1315                                                          system #:graft? #f))))
1316                 drv))))
1317
1318 (define* (package-output store package
1319                          #:optional (output "out") (system (%current-system)))
1320   "Return the output path of PACKAGE's OUTPUT for SYSTEM---where OUTPUT is the
1321 symbolic output name, such as \"out\".  Note that this procedure calls
1322 `package-derivation', which is costly."
1323   (let ((drv (package-derivation store package system)))
1324     (derivation->output-path drv output)))
1325
1326 \f
1327 ;;;
1328 ;;; Monadic interface.
1329 ;;;
1330
1331 (define (set-guile-for-build guile)
1332   "This monadic procedure changes the Guile currently used to run the build
1333 code of derivations to GUILE, a package object."
1334   (lambda (store)
1335     (let ((guile (package-derivation store guile)))
1336       (values (%guile-for-build guile) store))))
1337
1338 (define* (package-file package
1339                        #:optional file
1340                        #:key
1341                        system (output "out") target)
1342   "Return as a monadic value the absolute file name of FILE within the
1343 OUTPUT directory of PACKAGE.  When FILE is omitted, return the name of the
1344 OUTPUT directory of PACKAGE.  When TARGET is true, use it as a
1345 cross-compilation target triplet.
1346
1347 Note that this procedure does _not_ build PACKAGE.  Thus, the result might or
1348 might not designate an existing file.  We recommend not using this procedure
1349 unless you know what you are doing."
1350   (lambda (store)
1351     (define compute-derivation
1352       (if target
1353           (cut package-cross-derivation <> <> target <>)
1354           package-derivation))
1355
1356     (let* ((system (or system (%current-system)))
1357            (drv    (compute-derivation store package system))
1358            (out    (derivation->output-path drv output)))
1359       (values (if file
1360                   (string-append out "/" file)
1361                   out)
1362               store))))
1363
1364 (define package->derivation
1365   (store-lift package-derivation))
1366
1367 (define package->cross-derivation
1368   (store-lift package-cross-derivation))
1369
1370 (define-gexp-compiler (package-compiler (package <package>) system target)
1371   ;; Compile PACKAGE to a derivation for SYSTEM, optionally cross-compiled for
1372   ;; TARGET.  This is used when referring to a package from within a gexp.
1373   (if target
1374       (package->cross-derivation package target system)
1375       (package->derivation package system)))
1376
1377 (define* (origin->derivation origin
1378                              #:optional (system (%current-system)))
1379   "Return the derivation corresponding to ORIGIN."
1380   (match origin
1381     (($ <origin> uri method sha256 name (= force ()) #f)
1382      ;; No patches, no snippet: this is a fixed-output derivation.
1383      (method uri 'sha256 sha256 name #:system system))
1384     (($ <origin> uri method sha256 name (= force (patches ...)) snippet
1385         (flags ...) inputs (modules ...) guile-for-build)
1386      ;; Patches and/or a snippet.
1387      (mlet %store-monad ((source (method uri 'sha256 sha256 name
1388                                          #:system system))
1389                          (guile  (package->derivation (or guile-for-build
1390                                                           (default-guile))
1391                                                       system
1392                                                       #:graft? #f)))
1393        (patch-and-repack source patches
1394                          #:inputs inputs
1395                          #:snippet snippet
1396                          #:flags flags
1397                          #:system system
1398                          #:modules modules
1399                          #:guile-for-build guile)))))
1400
1401 (define-gexp-compiler (origin-compiler (origin <origin>) system target)
1402   ;; Compile ORIGIN to a derivation for SYSTEM.  This is used when referring
1403   ;; to an origin from within a gexp.
1404   (origin->derivation origin system))
1405
1406 (define package-source-derivation                 ;somewhat deprecated
1407   (let ((lower (store-lower lower-object)))
1408     (lambda* (store source #:optional (system (%current-system)))
1409       "Return the derivation or file corresponding to SOURCE, which can be an
1410 a file name or any object handled by 'lower-object', such as an <origin>.
1411 When SOURCE is a file name, return either the interned file name (if SOURCE is
1412 outside of the store) or SOURCE itself (if SOURCE is already a store item.)"
1413       (match source
1414         ((and (? string?) (? direct-store-path?) file)
1415          file)
1416         ((? string? file)
1417          (add-to-store store (basename file) #t "sha256" file))
1418         (_
1419          (lower store source system))))))