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