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