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