guix/packages.scm

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