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                         ;; TODO: Remove this on the next rebuild cycle.
 646                         #:pre-load-modules? #f
 647
 648                         #:graft? #f
 649                         #:system system
 650                         #:deprecation-warnings #t ;to avoid a rebuild
 651                         #:guile-for-build guile-for-build
 652                         #:properties `((type . origin)
 653                                        (patches . ,(length patches)))))))
 654
 655 (define (transitive-inputs inputs)
 656   "Return the closure of INPUTS when considering the 'propagated-inputs'
 657 edges.  Omit duplicate inputs, except for those already present in INPUTS
 658 itself.
 659
 660 This is implemented as a breadth-first traversal such that INPUTS is
 661 preserved, and only duplicate propagated inputs are removed."
 662   (define (seen? seen item outputs)
 663     ;; FIXME: We're using pointer identity here, which is extremely sensitive
 664     ;; to memoization in package-producing procedures; see
 665     ;; <https://bugs.gnu.org/30155>.
 666     (match (vhash-assq item seen)
 667       ((_ . o) (equal? o outputs))
 668       (_       #f)))
 669
 670   (let loop ((inputs     inputs)
 671              (result     '())
 672              (propagated '())
 673              (first?     #t)
 674              (seen       vlist-null))
 675     (match inputs
 676       (()
 677        (if (null? propagated)
 678            (reverse result)
 679            (loop (reverse (concatenate propagated)) result '() #f seen)))
 680       (((and input (label (? package? package) outputs ...)) rest ...)
 681        (if (and (not first?) (seen? seen package outputs))
 682            (loop rest result propagated first? seen)
 683            (loop rest
 684                  (cons input result)
 685                  (cons (package-propagated-inputs package) propagated)
 686                  first?
 687                  (vhash-consq package outputs seen))))
 688       ((input rest ...)
 689        (loop rest (cons input result) propagated first? seen)))))
 690
 691 (define (package-direct-sources package)
 692   "Return all source origins associated with PACKAGE; including origins in
 693 PACKAGE's inputs."
 694   `(,@(or (and=> (package-source package) list) '())
 695     ,@(filter-map (match-lambda
 696                    ((_ (? origin? orig) _ ...)
 697                     orig)
 698                    (_ #f))
 699                   (package-direct-inputs package))))
 700
 701 (define (package-transitive-sources package)
 702   "Return PACKAGE's direct sources, and their direct sources, recursively."
 703   (delete-duplicates
 704    (concatenate (filter-map (match-lambda
 705                              ((_ (? origin? orig) _ ...)
 706                               (list orig))
 707                              ((_ (? package? p) _ ...)
 708                               (package-direct-sources p))
 709                              (_ #f))
 710                             (bag-transitive-inputs
 711                              (package->bag package))))))
 712
 713 (define (package-direct-inputs package)
 714   "Return all the direct inputs of PACKAGE---i.e, its direct inputs along
 715 with their propagated inputs."
 716   (append (package-native-inputs package)
 717           (package-inputs package)
 718           (package-propagated-inputs package)))
 719
 720 (define (package-transitive-inputs package)
 721   "Return the transitive inputs of PACKAGE---i.e., its direct inputs along
 722 with their propagated inputs, recursively."
 723   (transitive-inputs (package-direct-inputs package)))
 724
 725 (define (package-transitive-target-inputs package)
 726   "Return the transitive target inputs of PACKAGE---i.e., its direct inputs
 727 along with their propagated inputs, recursively.  This only includes inputs
 728 for the target system, and not native inputs."
 729   (transitive-inputs (append (package-inputs package)
 730                              (package-propagated-inputs package))))
 731
 732 (define (package-transitive-native-inputs package)
 733   "Return the transitive native inputs of PACKAGE---i.e., its direct inputs
 734 along with their propagated inputs, recursively.  This only includes inputs
 735 for the host system (\"native inputs\"), and not target inputs."
 736   (transitive-inputs (package-native-inputs package)))
 737
 738 (define (package-transitive-propagated-inputs package)
 739   "Return the propagated inputs of PACKAGE, and their propagated inputs,
 740 recursively."
 741   (transitive-inputs (package-propagated-inputs package)))
 742
 743 (define (package-transitive-native-search-paths package)
 744   "Return the list of search paths for PACKAGE and its propagated inputs,
 745 recursively."
 746   (append (package-native-search-paths package)
 747           (append-map (match-lambda
 748                         ((label (? package? p) _ ...)
 749                          (package-native-search-paths p))
 750                         (_
 751                          '()))
 752                       (package-transitive-propagated-inputs package))))
 753
 754 (define (transitive-input-references alist inputs)
 755   "Return a list of (assoc-ref ALIST <label>) for each (<label> <package> . _)
 756 in INPUTS and their transitive propagated inputs."
 757   (define label
 758     (match-lambda
 759       ((label . _)
 760        label)))
 761
 762   (map (lambda (input)
 763          `(assoc-ref ,alist ,(label input)))
 764        (transitive-inputs inputs)))
 765
 766 (define package-transitive-supported-systems
 767   (mlambdaq (package)
 768     "Return the intersection of the systems supported by PACKAGE and those
 769 supported by its dependencies."
 770     (fold (lambda (input systems)
 771             (match input
 772               ((label (? package? p) . _)
 773                (lset-intersection
 774                 string=? systems (package-transitive-supported-systems p)))
 775               (_
 776                systems)))
 777           (package-supported-systems package)
 778           (bag-direct-inputs (package->bag package)))))
 779
 780 (define* (supported-package? package #:optional (system (%current-system)))
 781   "Return true if PACKAGE is supported on SYSTEM--i.e., if PACKAGE and all its
 782 dependencies are known to build on SYSTEM."
 783   (member system (package-transitive-supported-systems package)))
 784
 785 (define (bag-direct-inputs bag)
 786   "Same as 'package-direct-inputs', but applied to a bag."
 787   (append (bag-build-inputs bag)
 788           (bag-host-inputs bag)
 789           (bag-target-inputs bag)))
 790
 791 (define (bag-transitive-inputs bag)
 792   "Same as 'package-transitive-inputs', but applied to a bag."
 793   (transitive-inputs (bag-direct-inputs bag)))
 794
 795 (define (bag-transitive-build-inputs bag)
 796   "Same as 'package-transitive-native-inputs', but applied to a bag."
 797   (transitive-inputs (bag-build-inputs bag)))
 798
 799 (define (bag-transitive-host-inputs bag)
 800   "Same as 'package-transitive-target-inputs', but applied to a bag."
 801   (transitive-inputs (bag-host-inputs bag)))
 802
 803 (define (bag-transitive-target-inputs bag)
 804   "Return the \"target inputs\" of BAG, recursively."
 805   (transitive-inputs (bag-target-inputs bag)))
 806
 807 (define* (package-closure packages #:key (system (%current-system)))
 808   "Return the closure of PACKAGES on SYSTEM--i.e., PACKAGES and the list of
 809 packages they depend on, recursively."
 810   (let loop ((packages packages)
 811              (visited  vlist-null)
 812              (closure  (list->setq packages)))
 813     (match packages
 814       (()
 815        (set->list closure))
 816       ((package . rest)
 817        (if (vhash-assq package visited)
 818            (loop rest visited closure)
 819            (let* ((bag          (package->bag package system))
 820                   (dependencies (filter-map (match-lambda
 821                                               ((label (? package? package) . _)
 822                                                package)
 823                                               (_ #f))
 824                                             (bag-direct-inputs bag))))
 825              (loop (append dependencies rest)
 826                    (vhash-consq package #t visited)
 827                    (fold set-insert closure dependencies))))))))
 828
 829 (define* (package-mapping proc #:optional (cut? (const #f)))
 830   "Return a procedure that, given a package, applies PROC to all the packages
 831 depended on and returns the resulting package.  The procedure stops recursion
 832 when CUT? returns true for a given package."
 833   (define (rewrite input)
 834     (match input
 835       ((label (? package? package) outputs ...)
 836        (let ((proc (if (cut? package) proc replace)))
 837          (cons* label (proc package) outputs)))
 838       (_
 839        input)))
 840
 841   (define replace
 842     (mlambdaq (p)
 843       ;; Return a variant of P with PROC applied to P and its explicit
 844       ;; dependencies, recursively.  Memoize the transformations.  Failing to
 845       ;; do that, we would build a huge object graph with lots of duplicates,
 846       ;; which in turns prevents us from benefiting from memoization in
 847       ;; 'package-derivation'.
 848       (let ((p (proc p)))
 849         (package
 850           (inherit p)
 851           (location (package-location p))
 852           (inputs (map rewrite (package-inputs p)))
 853           (native-inputs (map rewrite (package-native-inputs p)))
 854           (propagated-inputs (map rewrite (package-propagated-inputs p)))
 855           (replacement (and=> (package-replacement p) proc))))))
 856
 857   replace)
 858
 859 (define* (package-input-rewriting replacements
 860                                   #:optional (rewrite-name identity))
 861   "Return a procedure that, when passed a package, replaces its direct and
 862 indirect dependencies (but not its implicit inputs) according to REPLACEMENTS.
 863 REPLACEMENTS is a list of package pairs; the first element of each pair is the
 864 package to replace, and the second one is the replacement.
 865
 866 Optionally, REWRITE-NAME is a one-argument procedure that takes the name of a
 867 package and returns its new name after rewrite."
 868   (define (rewrite p)
 869     (match (assq-ref replacements p)
 870       (#f  (package
 871              (inherit p)
 872              (name (rewrite-name (package-name p)))))
 873       (new new)))
 874
 875   (package-mapping rewrite (cut assq <> replacements)))
 876
 877 (define (package-input-rewriting/spec replacements)
 878   "Return a procedure that, given a package, applies the given REPLACEMENTS to
 879 all the package graph (excluding implicit inputs).  REPLACEMENTS is a list of
 880 spec/procedures pair; each spec is a package specification such as \"gcc\" or
 881 \"guile@2\", and each procedure takes a matching package and returns a
 882 replacement for that package."
 883   (define table
 884     (fold (lambda (replacement table)
 885             (match replacement
 886               ((spec . proc)
 887                (let-values (((name version)
 888                              (package-name->name+version spec)))
 889                  (vhash-cons name (list version proc) table)))))
 890           vlist-null
 891           replacements))
 892
 893   (define (find-replacement package)
 894     (vhash-fold* (lambda (item proc)
 895                    (or proc
 896                        (match item
 897                          ((#f proc)
 898                           proc)
 899                          ((version proc)
 900                           (and (version-prefix? version
 901                                                 (package-version package))
 902                                proc)))))
 903                  #f
 904                  (package-name package)
 905                  table))
 906
 907   (define (rewrite package)
 908     (match (find-replacement package)
 909       (#f package)
 910       (proc (proc package))))
 911
 912   (package-mapping rewrite find-replacement))
 913
 914 (define-syntax-rule (package/inherit p overrides ...)
 915   "Like (package (inherit P) OVERRIDES ...), except that the same
 916 transformation is done to the package replacement, if any.  P must be a bare
 917 identifier, and will be bound to either P or its replacement when evaluating
 918 OVERRIDES."
 919   (let loop ((p p))
 920     (package (inherit p)
 921       overrides ...
 922       (replacement (and=> (package-replacement p) loop)))))
 923
 924 \f
 925 ;;;
 926 ;;; Package derivations.
 927 ;;;
 928
 929 (define %derivation-cache
 930   ;; Package to derivation-path mapping.
 931   (make-weak-key-hash-table 100))
 932
 933 (define (cache! cache package system thunk)
 934   "Memoize in CACHE the return values of THUNK as the derivation of PACKAGE on
 935 SYSTEM."
 936   ;; FIXME: This memoization should be associated with the open store, because
 937   ;; otherwise it breaks when switching to a different store.
 938   (let ((result (thunk)))
 939     ;; Use `hashq-set!' instead of `hash-set!' because `hash' returns the
 940     ;; same value for all structs (as of Guile 2.0.6), and because pointer
 941     ;; equality is sufficient in practice.
 942     (hashq-set! cache package
 943                 `((,system . ,result)
 944                   ,@(or (hashq-ref cache package) '())))
 945     result))
 946
 947 (define-syntax cached
 948   (syntax-rules (=>)
 949     "Memoize the result of BODY for the arguments PACKAGE and SYSTEM.
 950 Return the cached result when available."
 951     ((_ (=> cache) package system body ...)
 952      (let ((thunk (lambda () body ...))
 953            (key   system))
 954        (match (hashq-ref cache package)
 955          ((alist (... ...))
 956           (match (assoc-ref alist key)
 957             (#f (cache! cache package key thunk))
 958             (value value)))
 959          (#f
 960           (cache! cache package key thunk)))))
 961     ((_ package system body ...)
 962      (cached (=> %derivation-cache) package system body ...))))
 963
 964 (define* (expand-input store package input system #:optional cross-system)
 965   "Expand INPUT, an input tuple, such that it contains only references to
 966 derivation paths or store paths.  PACKAGE is only used to provide contextual
 967 information in exceptions."
 968   (define (intern file)
 969     ;; Add FILE to the store.  Set the `recursive?' bit to #t, so that
 970     ;; file permissions are preserved.
 971     (add-to-store store (basename file) #t "sha256" file))
 972
 973   (define derivation
 974     (if cross-system
 975         (cut package-cross-derivation store <> cross-system system
 976              #:graft? #f)
 977         (cut package-derivation store <> system #:graft? #f)))
 978
 979   (match input
 980     (((? string? name) (? package? package))
 981      (list name (derivation package)))
 982     (((? string? name) (? package? package)
 983       (? string? sub-drv))
 984      (list name (derivation package)
 985            sub-drv))
 986     (((? string? name)
 987       (and (? string?) (? derivation-path?) drv))
 988      (list name drv))
 989     (((? string? name)
 990       (and (? string?) (? file-exists? file)))
 991      ;; Add FILE to the store.  When FILE is in the sub-directory of a
 992      ;; store path, it needs to be added anyway, so it can be used as a
 993      ;; source.
 994      (list name (intern file)))
 995     (((? string? name) (? struct? source))
 996      ;; 'package-source-derivation' calls 'lower-object', which can throw
 997      ;; '&gexp-input-error'.  However '&gexp-input-error' lacks source
 998      ;; location info, so we catch and rethrow here (XXX: not optimal
 999      ;; performance-wise).
1000      (guard (c ((gexp-input-error? c)
1001                 (raise (condition
1002                         (&package-input-error
1003                          (package package)
1004                          (input   (gexp-error-invalid-input c)))))))
1005        (list name (package-source-derivation store source system))))
1006     (x
1007      (raise (condition (&package-input-error
1008                         (package package)
1009                         (input   x)))))))
1010
1011 (define %bag-cache
1012   ;; 'eq?' cache mapping packages to system+target+graft?-dependent bags.
1013   ;; It significantly speeds things up when doing repeated calls to
1014   ;; 'package->bag' as is the case when building a profile.
1015   (make-weak-key-hash-table 200))
1016
1017 (define* (package->bag package #:optional
1018                        (system (%current-system))
1019                        (target (%current-target-system))
1020                        #:key (graft? (%graft?)))
1021   "Compile PACKAGE into a bag for SYSTEM, possibly cross-compiled to TARGET,
1022 and return it."
1023   (cached (=> %bag-cache)
1024           package (list system target graft?)
1025           ;; Bind %CURRENT-SYSTEM and %CURRENT-TARGET-SYSTEM so that thunked
1026           ;; field values can refer to it.
1027           (parameterize ((%current-system system)
1028                          (%current-target-system target))
1029             (match (if graft?
1030                        (or (package-replacement package) package)
1031                        package)
1032               ((and self
1033                     ($ <package> name version source build-system
1034                                  args inputs propagated-inputs native-inputs
1035                                  outputs))
1036                ;; Even though we prefer to use "@" to separate the package
1037                ;; name from the package version in various user-facing parts
1038                ;; of Guix, checkStoreName (in nix/libstore/store-api.cc)
1039                ;; prohibits the use of "@", so use "-" instead.
1040                (or (make-bag build-system (string-append name "-" version)
1041                              #:system system
1042                              #:target target
1043                              #:source source
1044                              #:inputs (append (inputs self)
1045                                               (propagated-inputs self))
1046                              #:outputs outputs
1047                              #:native-inputs (native-inputs self)
1048                              #:arguments (args self))
1049                    (raise (if target
1050                               (condition
1051                                (&package-cross-build-system-error
1052                                 (package package)))
1053                               (condition
1054                                (&package-error
1055                                 (package package)))))))))))
1056
1057 (define %graft-cache
1058   ;; 'eq?' cache mapping package objects to a graft corresponding to their
1059   ;; replacement package.
1060   (make-weak-key-hash-table 200))
1061
1062 (define (input-graft store system)
1063   "Return a procedure that, given a package with a graft, returns a graft, and
1064 #f otherwise."
1065   (match-lambda
1066     ((? package? package)
1067      (let ((replacement (package-replacement package)))
1068        (and replacement
1069             (cached (=> %graft-cache) package system
1070                     (let ((orig (package-derivation store package system
1071                                                     #:graft? #f))
1072                           (new  (package-derivation store replacement system
1073                                                     #:graft? #t)))
1074                       (graft
1075                         (origin orig)
1076                         (replacement new)))))))
1077     (x
1078      #f)))
1079
1080 (define (input-cross-graft store target system)
1081   "Same as 'input-graft', but for cross-compilation inputs."
1082   (match-lambda
1083     ((? package? package)
1084     (let ((replacement (package-replacement package)))
1085       (and replacement
1086            (let ((orig (package-cross-derivation store package target system
1087                                                  #:graft? #f))
1088                  (new  (package-cross-derivation store replacement
1089                                                  target system
1090                                                  #:graft? #t)))
1091              (graft
1092                (origin orig)
1093                (replacement new))))))
1094    (_
1095     #f)))
1096
1097 (define* (fold-bag-dependencies proc seed bag
1098                                 #:key (native? #t))
1099   "Fold PROC over the packages BAG depends on.  Each package is visited only
1100 once, in depth-first order.  If NATIVE? is true, restrict to native
1101 dependencies; otherwise, restrict to target dependencies."
1102   (define bag-direct-inputs*
1103     (if native?
1104         (lambda (bag)
1105           (append (bag-build-inputs bag)
1106                   (bag-target-inputs bag)
1107                   (if (bag-target bag)
1108                       '()
1109                       (bag-host-inputs bag))))
1110         bag-host-inputs))
1111
1112   (define nodes
1113     (match (bag-direct-inputs* bag)
1114       (((labels things _ ...) ...)
1115        things)))
1116
1117   (let loop ((nodes nodes)
1118              (result seed)
1119              (visited (setq)))
1120     (match nodes
1121       (()
1122        result)
1123       (((? package? head) . tail)
1124        (if (set-contains? visited head)
1125            (loop tail result visited)
1126            (let ((inputs (bag-direct-inputs* (package->bag head))))
1127              (loop (match inputs
1128                      (((labels things _ ...) ...)
1129                       (append things tail)))
1130                    (proc head result)
1131                    (set-insert head visited)))))
1132       ((head . tail)
1133        (loop tail result visited)))))
1134
1135 (define* (bag-grafts store bag)
1136   "Return the list of grafts potentially applicable to BAG.  Potentially
1137 applicable grafts are collected by looking at direct or indirect dependencies
1138 of BAG that have a 'replacement'.  Whether a graft is actually applicable
1139 depends on whether the outputs of BAG depend on the items the grafts refer
1140 to (see 'graft-derivation'.)"
1141   (define system (bag-system bag))
1142   (define target (bag-target bag))
1143
1144   (define native-grafts
1145     (let ((->graft (input-graft store system)))
1146       (fold-bag-dependencies (lambda (package grafts)
1147                                (match (->graft package)
1148                                  (#f    grafts)
1149                                  (graft (cons graft grafts))))
1150                              '()
1151                              bag)))
1152
1153   (define target-grafts
1154     (if target
1155         (let ((->graft (input-cross-graft store target system)))
1156           (fold-bag-dependencies (lambda (package grafts)
1157                                    (match (->graft package)
1158                                      (#f    grafts)
1159                                      (graft (cons graft grafts))))
1160                                  '()
1161                                  bag
1162                                  #:native? #f))
1163         '()))
1164
1165   ;; We can end up with several identical grafts if we stumble upon packages
1166   ;; that are not 'eq?' but map to the same derivation (this can happen when
1167   ;; using things like 'package-with-explicit-inputs'.)  Hence the
1168   ;; 'delete-duplicates' call.
1169   (delete-duplicates
1170    (append native-grafts target-grafts)))
1171
1172 (define* (package-grafts store package
1173                          #:optional (system (%current-system))
1174                          #:key target)
1175   "Return the list of grafts applicable to PACKAGE as built for SYSTEM and
1176 TARGET."
1177   (let* ((package (or (package-replacement package) package))
1178          (bag     (package->bag package system target)))
1179     (bag-grafts store bag)))
1180
1181 (define* (bag->derivation store bag
1182                           #:optional context)
1183   "Return the derivation to build BAG for SYSTEM.  Optionally, CONTEXT can be
1184 a package object describing the context in which the call occurs, for improved
1185 error reporting."
1186   (if (bag-target bag)
1187       (bag->cross-derivation store bag)
1188       (let* ((system     (bag-system bag))
1189              (inputs     (bag-transitive-inputs bag))
1190              (input-drvs (map (cut expand-input store context <> system)
1191                               inputs))
1192              (paths      (delete-duplicates
1193                           (append-map (match-lambda
1194                                        ((_ (? package? p) _ ...)
1195                                         (package-native-search-paths
1196                                          p))
1197                                        (_ '()))
1198                                       inputs))))
1199
1200         (apply (bag-build bag)
1201                store (bag-name bag) input-drvs
1202                #:search-paths paths
1203                #:outputs (bag-outputs bag) #:system system
1204                (bag-arguments bag)))))
1205
1206 (define* (bag->cross-derivation store bag
1207                                 #:optional context)
1208   "Return the derivation to build BAG, which is actually a cross build.
1209 Optionally, CONTEXT can be a package object denoting the context of the call.
1210 This is an internal procedure."
1211   (let* ((system      (bag-system bag))
1212          (target      (bag-target bag))
1213          (host        (bag-transitive-host-inputs bag))
1214          (host-drvs   (map (cut expand-input store context <> system target)
1215                            host))
1216          (target*     (bag-transitive-target-inputs bag))
1217          (target-drvs (map (cut expand-input store context <> system)
1218                            target*))
1219          (build       (bag-transitive-build-inputs bag))
1220          (build-drvs  (map (cut expand-input store context <> system)
1221                            build))
1222          (all         (append build target* host))
1223          (paths       (delete-duplicates
1224                        (append-map (match-lambda
1225                                     ((_ (? package? p) _ ...)
1226                                      (package-search-paths p))
1227                                     (_ '()))
1228                                    all)))
1229          (npaths      (delete-duplicates
1230                        (append-map (match-lambda
1231                                     ((_ (? package? p) _ ...)
1232                                      (package-native-search-paths
1233                                       p))
1234                                     (_ '()))
1235                                    all))))
1236
1237     (apply (bag-build bag)
1238            store (bag-name bag)
1239            #:native-drvs build-drvs
1240            #:target-drvs (append host-drvs target-drvs)
1241            #:search-paths paths
1242            #:native-search-paths npaths
1243            #:outputs (bag-outputs bag)
1244            #:system system #:target target
1245            (bag-arguments bag))))
1246
1247 (define* (package-derivation store package
1248                              #:optional (system (%current-system))
1249                              #:key (graft? (%graft?)))
1250   "Return the <derivation> object of PACKAGE for SYSTEM."
1251
1252   ;; Compute the derivation and cache the result.  Caching is important
1253   ;; because some derivations, such as the implicit inputs of the GNU build
1254   ;; system, will be queried many, many times in a row.
1255   (cached package (cons system graft?)
1256           (let* ((bag (package->bag package system #f #:graft? graft?))
1257                  (drv (bag->derivation store bag package)))
1258             (if graft?
1259                 (match (bag-grafts store bag)
1260                   (()
1261                    drv)
1262                   (grafts
1263                    (let ((guile (package-derivation store (guile-2.0)
1264                                                     system #:graft? #f)))
1265                      ;; TODO: As an optimization, we can simply graft the tip
1266                      ;; of the derivation graph since 'graft-derivation'
1267                      ;; recurses anyway.
1268                      (graft-derivation store drv grafts
1269                                        #:system system
1270                                        #:guile guile))))
1271                 drv))))
1272
1273 (define* (package-cross-derivation store package target
1274                                    #:optional (system (%current-system))
1275                                    #:key (graft? (%graft?)))
1276   "Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix
1277 system identifying string)."
1278   (cached package (list system target graft?)
1279           (let* ((bag (package->bag package system target #:graft? graft?))
1280                  (drv (bag->derivation store bag package)))
1281             (if graft?
1282                 (match (bag-grafts store bag)
1283                   (()
1284                    drv)
1285                   (grafts
1286                    (graft-derivation store drv grafts
1287                                      #:system system
1288                                      #:guile
1289                                      (package-derivation store (guile-2.0)
1290                                                          system #:graft? #f))))
1291                 drv))))
1292
1293 (define* (package-output store package
1294                          #:optional (output "out") (system (%current-system)))
1295   "Return the output path of PACKAGE's OUTPUT for SYSTEM---where OUTPUT is the
1296 symbolic output name, such as \"out\".  Note that this procedure calls
1297 `package-derivation', which is costly."
1298   (let ((drv (package-derivation store package system)))
1299     (derivation->output-path drv output)))
1300
1301 \f
1302 ;;;
1303 ;;; Monadic interface.
1304 ;;;
1305
1306 (define (set-guile-for-build guile)
1307   "This monadic procedure changes the Guile currently used to run the build
1308 code of derivations to GUILE, a package object."
1309   (lambda (store)
1310     (let ((guile (package-derivation store guile)))
1311       (values (%guile-for-build guile) store))))
1312
1313 (define* (package-file package
1314                        #:optional file
1315                        #:key
1316                        system (output "out") target)
1317   "Return as a monadic value the absolute file name of FILE within the
1318 OUTPUT directory of PACKAGE.  When FILE is omitted, return the name of the
1319 OUTPUT directory of PACKAGE.  When TARGET is true, use it as a
1320 cross-compilation target triplet."
1321   (lambda (store)
1322     (define compute-derivation
1323       (if target
1324           (cut package-cross-derivation <> <> target <>)
1325           package-derivation))
1326
1327     (let* ((system (or system (%current-system)))
1328            (drv    (compute-derivation store package system))
1329            (out    (derivation->output-path drv output)))
1330       (values (if file
1331                   (string-append out "/" file)
1332                   out)
1333               store))))
1334
1335 (define package->derivation
1336   (store-lift package-derivation))
1337
1338 (define package->cross-derivation
1339   (store-lift package-cross-derivation))
1340
1341 (define-gexp-compiler (package-compiler (package <package>) system target)
1342   ;; Compile PACKAGE to a derivation for SYSTEM, optionally cross-compiled for
1343   ;; TARGET.  This is used when referring to a package from within a gexp.
1344   (if target
1345       (package->cross-derivation package target system)
1346       (package->derivation package system)))
1347
1348 (define* (origin->derivation origin
1349                              #:optional (system (%current-system)))
1350   "Return the derivation corresponding to ORIGIN."
1351   (match origin
1352     (($ <origin> uri method sha256 name (= force ()) #f)
1353      ;; No patches, no snippet: this is a fixed-output derivation.
1354      (method uri 'sha256 sha256 name #:system system))
1355     (($ <origin> uri method sha256 name (= force (patches ...)) snippet
1356         (flags ...) inputs (modules ...) guile-for-build)
1357      ;; Patches and/or a snippet.
1358      (mlet %store-monad ((source (method uri 'sha256 sha256 name
1359                                          #:system system))
1360                          (guile  (package->derivation (or guile-for-build
1361                                                           (default-guile))
1362                                                       system
1363                                                       #:graft? #f)))
1364        (patch-and-repack source patches
1365                          #:inputs inputs
1366                          #:snippet snippet
1367                          #:flags flags
1368                          #:system system
1369                          #:modules modules
1370                          #:guile-for-build guile)))))
1371
1372 (define-gexp-compiler (origin-compiler (origin <origin>) system target)
1373   ;; Compile ORIGIN to a derivation for SYSTEM.  This is used when referring
1374   ;; to an origin from within a gexp.
1375   (origin->derivation origin system))
1376
1377 (define package-source-derivation                 ;somewhat deprecated
1378   (let ((lower (store-lower lower-object)))
1379     (lambda* (store source #:optional (system (%current-system)))
1380       "Return the derivation or file corresponding to SOURCE, which can be an
1381 a file name or any object handled by 'lower-object', such as an <origin>.
1382 When SOURCE is a file name, return either the interned file name (if SOURCE is
1383 outside of the store) or SOURCE itself (if SOURCE is already a store item.)"
1384       (match source
1385         ((and (? string?) (? direct-store-path?) file)
1386          file)
1387         ((? string? file)
1388          (add-to-store store (basename file) #t "sha256" file))
1389         (_
1390          (lower store source system))))))