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