guix/packages.scm

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