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