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