guix/packages.scm

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