guix/packages.scm

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