guix/packages.scm

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