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