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