guix/packages.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2014 Mark H Weaver <mhw@netris.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (guix packages)
  21   #:use-module (guix utils)
  22   #:use-module (guix records)
  23   #:use-module (guix store)
  24   #:use-module (guix base32)
  25   #:use-module (guix derivations)
  26   #:use-module (guix build-system)
  27   #:use-module (ice-9 match)
  28   #:use-module (ice-9 vlist)
  29   #:use-module (srfi srfi-1)
  30   #:use-module (srfi srfi-9 gnu)
  31   #:use-module (srfi srfi-11)
  32   #:use-module (srfi srfi-26)
  33   #:use-module (srfi srfi-34)
  34   #:use-module (srfi srfi-35)
  35   #:re-export (%current-system
  36                %current-target-system)
  37   #:export (origin
  38             origin?
  39             origin-uri
  40             origin-method
  41             origin-sha256
  42             origin-file-name
  43             origin-patches
  44             origin-patch-flags
  45             origin-patch-inputs
  46             origin-patch-guile
  47             origin-snippet
  48             origin-modules
  49             origin-imported-modules
  50             base32
  51
  52             <search-path-specification>
  53             search-path-specification
  54             search-path-specification?
  55             search-path-specification->sexp
  56
  57             package
  58             package?
  59             package-name
  60             package-version
  61             package-full-name
  62             package-source
  63             package-build-system
  64             package-arguments
  65             package-inputs
  66             package-native-inputs
  67             package-propagated-inputs
  68             package-outputs
  69             package-native-search-paths
  70             package-search-paths
  71             package-replacement
  72             package-synopsis
  73             package-description
  74             package-license
  75             package-home-page
  76             package-supported-systems
  77             package-maintainers
  78             package-properties
  79             package-location
  80             package-field-location
  81
  82             package-direct-inputs
  83             package-transitive-inputs
  84             package-transitive-target-inputs
  85             package-transitive-native-inputs
  86             package-transitive-propagated-inputs
  87             package-transitive-supported-systems
  88             package-source-derivation
  89             package-derivation
  90             package-cross-derivation
  91             package-output
  92             package-grafts
  93
  94             %supported-systems
  95
  96             &package-error
  97             package-error?
  98             package-error-package
  99             &package-input-error
 100             package-input-error?
 101             package-error-invalid-input
 102             &package-cross-build-system-error
 103             package-cross-build-system-error?
 104
 105             %graft?
 106             package->bag
 107             bag->derivation
 108             bag-transitive-inputs
 109             bag-transitive-host-inputs
 110             bag-transitive-build-inputs
 111             bag-transitive-target-inputs))
 112
 113 ;;; Commentary:
 114 ;;;
 115 ;;; This module provides a high-level mechanism to define packages in a
 116 ;;; Guix-based distribution.
 117 ;;;
 118 ;;; Code:
 119
 120 ;; The source of a package, such as a tarball URL and fetcher---called
 121 ;; "origin" to avoid name clash with `package-source', `source', etc.
 122 (define-record-type* <origin>
 123   origin make-origin
 124   origin?
 125   (uri       origin-uri)                          ; string
 126   (method    origin-method)                       ; procedure
 127   (sha256    origin-sha256)                       ; bytevector
 128   (file-name origin-file-name (default #f))       ; optional file name
 129   (patches   origin-patches (default '()))        ; list of file names
 130   (snippet   origin-snippet (default #f))         ; sexp or #f
 131   (patch-flags  origin-patch-flags                ; list of strings
 132                 (default '("-p1")))
 133
 134   ;; Patching requires Guile, GNU Patch, and a few more.  These two fields are
 135   ;; used to specify these dependencies when needed.
 136   (patch-inputs origin-patch-inputs               ; input list or #f
 137                 (default #f))
 138   (modules      origin-modules                    ; list of module names
 139                 (default '()))
 140   (imported-modules origin-imported-modules       ; list of module names
 141                     (default '()))
 142   (patch-guile origin-patch-guile                 ; package or #f
 143                (default #f)))
 144
 145 (define (print-origin origin port)
 146   "Write a concise representation of ORIGIN to PORT."
 147   (match origin
 148     (($ <origin> uri method sha256 file-name patches)
 149      (simple-format port "#<origin ~s ~a ~s ~a>"
 150                     uri (bytevector->base32-string sha256)
 151                     patches
 152                     (number->string (object-address origin) 16)))))
 153
 154 (set-record-type-printer! <origin> print-origin)
 155
 156 (define-syntax base32
 157   (lambda (s)
 158     "Return the bytevector corresponding to the given Nix-base32
 159 representation."
 160     (syntax-case s ()
 161       ((_ str)
 162        (string? (syntax->datum #'str))
 163        ;; A literal string: do the conversion at expansion time.
 164        (with-syntax ((bv (nix-base32-string->bytevector
 165                           (syntax->datum #'str))))
 166          #''bv))
 167       ((_ str)
 168        #'(nix-base32-string->bytevector str)))))
 169
 170 ;; The specification of a search path.
 171 (define-record-type* <search-path-specification>
 172   search-path-specification make-search-path-specification
 173   search-path-specification?
 174   (variable     search-path-specification-variable)
 175   (directories  search-path-specification-directories)
 176   (separator    search-path-specification-separator (default ":")))
 177
 178 (define (search-path-specification->sexp spec)
 179   "Return an sexp representing SPEC, a <search-path-specification>.  The sexp
 180 corresponds to the arguments expected by `set-path-environment-variable'."
 181   (match spec
 182     (($ <search-path-specification> variable directories separator)
 183      `(,variable ,directories ,separator))))
 184
 185 (define %supported-systems
 186   ;; This is the list of system types that are supported.  By default, we
 187   ;; expect all packages to build successfully here.
 188   '("x86_64-linux" "i686-linux" "mips64el-linux"))
 189
 190 ;; A package.
 191 (define-record-type* <package>
 192   package make-package
 193   package?
 194   (name   package-name)                   ; string
 195   (version package-version)               ; string
 196   (source package-source)                 ; <origin> instance
 197   (build-system package-build-system)     ; build system
 198   (arguments package-arguments            ; arguments for the build method
 199              (default '()) (thunked))
 200
 201   (inputs package-inputs                  ; input packages or derivations
 202           (default '()) (thunked))
 203   (propagated-inputs package-propagated-inputs    ; same, but propagated
 204                      (default '()) (thunked))
 205   (native-inputs package-native-inputs    ; native input packages/derivations
 206                  (default '()) (thunked))
 207   (self-native-input? package-self-native-input?  ; whether to use itself as
 208                                                   ; a native input when cross-
 209                       (default #f))               ; compiling
 210
 211   (outputs package-outputs                ; list of strings
 212            (default '("out")))
 213
 214                                                   ; lists of
 215                                                   ; <search-path-specification>,
 216                                                   ; for native and cross
 217                                                   ; inputs
 218   (native-search-paths package-native-search-paths (default '()))
 219   (search-paths package-search-paths (default '()))
 220   (replacement package-replacement                ; package | #f
 221                (default #f) (thunked))
 222
 223   (synopsis package-synopsis)                    ; one-line description
 224   (description package-description)              ; one or two paragraphs
 225   (license package-license)
 226   (home-page package-home-page)
 227   (supported-systems package-supported-systems    ; list of strings
 228                      (default %supported-systems))
 229   (maintainers package-maintainers (default '()))
 230
 231   (properties package-properties (default '()))   ; alist for anything else
 232
 233   (location package-location
 234             (default (and=> (current-source-location)
 235                             source-properties->location))))
 236
 237 (set-record-type-printer! <package>
 238                           (lambda (package port)
 239                             (let ((loc    (package-location package))
 240                                   (format simple-format))
 241                               (format port "#<package ~a-~a ~a~a>"
 242                                       (package-name package)
 243                                       (package-version package)
 244                                       (if loc
 245                                           (format #f "~a:~a "
 246                                                   (location-file loc)
 247                                                   (location-line loc))
 248                                           "")
 249                                       (number->string (object-address
 250                                                        package)
 251                                                       16)))))
 252
 253 (define (package-field-location package field)
 254   "Return the source code location of the definition of FIELD for PACKAGE, or
 255 #f if it could not be determined."
 256   (define (goto port line column)
 257     (unless (and (= (port-column port) (- column 1))
 258                  (= (port-line port) (- line 1)))
 259       (unless (eof-object? (read-char port))
 260         (goto port line column))))
 261
 262   (match (package-location package)
 263     (($ <location> file line column)
 264      (catch 'system
 265        (lambda ()
 266          ;; In general we want to keep relative file names for modules.
 267          (with-fluids ((%file-port-name-canonicalization 'relative))
 268            (call-with-input-file (search-path %load-path file)
 269              (lambda (port)
 270                (goto port line column)
 271                (match (read port)
 272                  (('package inits ...)
 273                   (let ((field (assoc field inits)))
 274                     (match field
 275                       ((_ value)
 276                        ;; Put the `or' here, and not in the first argument of
 277                        ;; `and=>', to work around a compiler bug in 2.0.5.
 278                        (or (and=> (source-properties value)
 279                                   source-properties->location)
 280                            (and=> (source-properties field)
 281                                   source-properties->location)))
 282                       (_
 283                        #f))))
 284                  (_
 285                   #f))))))
 286        (lambda _
 287          #f)))
 288     (_ #f)))
 289
 290
 291 ;; Error conditions.
 292
 293 (define-condition-type &package-error &error
 294   package-error?
 295   (package package-error-package))
 296
 297 (define-condition-type &package-input-error &package-error
 298   package-input-error?
 299   (input package-error-invalid-input))
 300
 301 (define-condition-type &package-cross-build-system-error &package-error
 302   package-cross-build-system-error?)
 303
 304
 305 (define (package-full-name package)
 306   "Return the full name of PACKAGE--i.e., `NAME-VERSION'."
 307   (string-append (package-name package) "-" (package-version package)))
 308
 309 (define (%standard-patch-inputs)
 310   (let ((ref (lambda (module var)
 311                (module-ref (resolve-interface module) var))))
 312     `(("tar"   ,(ref '(gnu packages base) 'tar))
 313       ("xz"    ,(ref '(gnu packages compression) 'xz))
 314       ("bzip2" ,(ref '(gnu packages compression) 'bzip2))
 315       ("gzip"  ,(ref '(gnu packages compression) 'gzip))
 316       ("lzip"  ,(ref '(gnu packages compression) 'lzip))
 317       ("patch" ,(ref '(gnu packages base) 'patch)))))
 318
 319 (define (default-guile)
 320   "Return the default Guile package for SYSTEM."
 321   (let ((distro (resolve-interface '(gnu packages commencement))))
 322     (module-ref distro 'guile-final)))
 323
 324 (define* (patch-and-repack store source patches
 325                            #:key
 326                            (inputs '())
 327                            (snippet #f)
 328                            (flags '("-p1"))
 329                            (modules '())
 330                            (imported-modules '())
 331                            (guile-for-build (%guile-for-build))
 332                            (system (%current-system)))
 333   "Unpack SOURCE (a derivation or store path), apply all of PATCHES, and
 334 repack the tarball using the tools listed in INPUTS.  When SNIPPET is true,
 335 it must be an s-expression that will run from within the directory where
 336 SOURCE was unpacked, after all of PATCHES have been applied.  MODULES and
 337 IMPORTED-MODULES specify modules to use/import for use by SNIPPET."
 338   (define source-file-name
 339     ;; SOURCE is usually a derivation, but it could be a store file.
 340     (if (derivation? source)
 341         (derivation->output-path source)
 342         source))
 343
 344   (define decompression-type
 345     (cond ((string-suffix? "gz" source-file-name)  "gzip")
 346           ((string-suffix? "bz2" source-file-name) "bzip2")
 347           ((string-suffix? "lz" source-file-name)  "lzip")
 348           (else "xz")))
 349
 350   (define original-file-name
 351     ;; Remove the store prefix plus the slash, hash, and hyphen.
 352     (let* ((sans (string-drop source-file-name
 353                               (+ (string-length (%store-prefix)) 1)))
 354            (dash (string-index sans #\-)))
 355       (string-drop sans (+ 1 dash))))
 356
 357   (define (numeric-extension? file-name)
 358     ;; Return true if FILE-NAME ends with digits.
 359     (and=> (file-extension file-name)
 360            (cut string-every char-set:hex-digit <>)))
 361
 362   (define (tarxz-name file-name)
 363     ;; Return a '.tar.xz' file name based on FILE-NAME.
 364     (let ((base (if (numeric-extension? file-name)
 365                     original-file-name
 366                     (file-sans-extension file-name))))
 367       (string-append base
 368                      (if (equal? (file-extension base) "tar")
 369                          ".xz"
 370                          ".tar.xz"))))
 371
 372   (define patch-inputs
 373     (map (lambda (number patch)
 374            (list (string-append "patch" (number->string number))
 375                  (match patch
 376                    ((? string?)
 377                     (add-to-store store (basename patch) #t
 378                                   "sha256" patch))
 379                    ((? origin?)
 380                     (package-source-derivation store patch system)))))
 381          (iota (length patches))
 382
 383          patches))
 384
 385   (define builder
 386     `(begin
 387        (use-modules (ice-9 ftw)
 388                     (srfi srfi-1)
 389                     (guix build utils))
 390
 391        (let ((out     (assoc-ref %outputs "out"))
 392              (xz      (assoc-ref %build-inputs "xz"))
 393              (decomp  (assoc-ref %build-inputs ,decompression-type))
 394              (source  (assoc-ref %build-inputs "source"))
 395              (tar     (string-append (assoc-ref %build-inputs "tar")
 396                                      "/bin/tar"))
 397              (patch   (string-append (assoc-ref %build-inputs "patch")
 398                                      "/bin/patch")))
 399          (define (apply-patch input)
 400            (let ((patch* (assoc-ref %build-inputs input)))
 401              (format (current-error-port) "applying '~a'...~%" patch*)
 402              (zero? (system* patch "--batch" ,@flags "--input" patch*))))
 403
 404          (define (first-file directory)
 405            ;; Return the name of the first file in DIRECTORY.
 406            (car (scandir directory
 407                          (lambda (name)
 408                            (not (member name '("." "..")))))))
 409
 410          (setenv "PATH" (string-append xz "/bin" ":"
 411                                        decomp "/bin"))
 412
 413          ;; SOURCE may be either a directory or a tarball.
 414          (and (if (file-is-directory? source)
 415                   (let* ((store     (or (getenv "NIX_STORE") "/gnu/store"))
 416                          (len       (+ 1 (string-length store)))
 417                          (base      (string-drop source len))
 418                          (dash      (string-index base #\-))
 419                          (directory (string-drop base (+ 1 dash))))
 420                     (mkdir directory)
 421                     (copy-recursively source directory)
 422                     #t)
 423                   (zero? (system* tar "xvf" source)))
 424               (let ((directory (first-file ".")))
 425                 (format (current-error-port)
 426                         "source is under '~a'~%" directory)
 427                 (chdir directory)
 428
 429                 (and (every apply-patch ',(map car patch-inputs))
 430
 431                      ,@(if snippet
 432                            `((let ((module (make-fresh-user-module)))
 433                                (module-use-interfaces! module
 434                                                        (map resolve-interface
 435                                                             ',modules))
 436                                (module-define! module '%build-inputs
 437                                                %build-inputs)
 438                                (module-define! module '%outputs %outputs)
 439                                ((@ (system base compile) compile)
 440                                 ',snippet
 441                                 #:to 'value
 442                                 #:opts %auto-compilation-options
 443                                 #:env module)))
 444                            '())
 445
 446                      (begin (chdir "..") #t)
 447                      (zero? (system* tar "cvfa" out directory))))))))
 448
 449
 450   (let ((name    (tarxz-name original-file-name))
 451         (inputs  (filter-map (match-lambda
 452                               ((name (? package? p))
 453                                (and (member name (cons decompression-type
 454                                                        '("tar" "xz" "patch")))
 455                                     (list name
 456                                           (package-derivation store p system
 457                                                               #:graft? #f)))))
 458                              (or inputs (%standard-patch-inputs))))
 459         (modules (delete-duplicates (cons '(guix build utils) modules))))
 460
 461     (build-expression->derivation store name builder
 462                                  #:inputs `(("source" ,source)
 463                                             ,@inputs
 464                                             ,@patch-inputs)
 465                                  #:system system
 466                                  #:modules modules
 467                                  #:guile-for-build guile-for-build)))
 468
 469 (define* (package-source-derivation store source
 470                                     #:optional (system (%current-system)))
 471   "Return the derivation path for SOURCE, a package source, for SYSTEM."
 472   (match source
 473     (($ <origin> uri method sha256 name () #f)
 474      ;; No patches, no snippet: this is a fixed-output derivation.
 475      (method store uri 'sha256 sha256 name
 476              #:system system))
 477     (($ <origin> uri method sha256 name (patches ...) snippet
 478         (flags ...) inputs (modules ...) (imported-modules ...)
 479         guile-for-build)
 480      ;; Patches and/or a snippet.
 481      (let ((source (method store uri 'sha256 sha256 name
 482                            #:system system))
 483            (guile  (match (or guile-for-build (default-guile))
 484                      ((? package? p)
 485                       (package-derivation store p system
 486                                           #:graft? #f)))))
 487        (patch-and-repack store source patches
 488                          #:inputs inputs
 489                          #:snippet snippet
 490                          #:flags flags
 491                          #:system system
 492                          #:modules modules
 493                          #:imported-modules modules
 494                          #:guile-for-build guile)))
 495     ((and (? string?) (? direct-store-path?) file)
 496      file)
 497     ((? string? file)
 498      (add-to-store store (basename file) #t "sha256" file))))
 499
 500 (define (transitive-inputs inputs)
 501   (let loop ((inputs  inputs)
 502              (result '()))
 503     (match inputs
 504       (()
 505        (delete-duplicates (reverse result)))      ; XXX: efficiency
 506       (((and i (name (? package? p) sub ...)) rest ...)
 507        (let ((t (map (match-lambda
 508                       ((dep-name derivation ...)
 509                        (cons (string-append name "/" dep-name)
 510                              derivation)))
 511                      (package-propagated-inputs p))))
 512          (loop (append t rest)
 513                (append t (cons i result)))))
 514       ((input rest ...)
 515        (loop rest (cons input result))))))
 516
 517 (define (package-direct-inputs package)
 518   "Return all the direct inputs of PACKAGE---i.e, its direct inputs along
 519 with their propagated inputs."
 520   (append (package-native-inputs package)
 521           (package-inputs package)
 522           (package-propagated-inputs package)))
 523
 524 (define (package-transitive-inputs package)
 525   "Return the transitive inputs of PACKAGE---i.e., its direct inputs along
 526 with their propagated inputs, recursively."
 527   (transitive-inputs (package-direct-inputs package)))
 528
 529 (define (package-transitive-target-inputs package)
 530   "Return the transitive target inputs of PACKAGE---i.e., its direct inputs
 531 along with their propagated inputs, recursively.  This only includes inputs
 532 for the target system, and not native inputs."
 533   (transitive-inputs (append (package-inputs package)
 534                              (package-propagated-inputs package))))
 535
 536 (define (package-transitive-native-inputs package)
 537   "Return the transitive native inputs of PACKAGE---i.e., its direct inputs
 538 along with their propagated inputs, recursively.  This only includes inputs
 539 for the host system (\"native inputs\"), and not target inputs."
 540   (transitive-inputs (package-native-inputs package)))
 541
 542 (define (package-transitive-propagated-inputs package)
 543   "Return the propagated inputs of PACKAGE, and their propagated inputs,
 544 recursively."
 545   (transitive-inputs (package-propagated-inputs package)))
 546
 547 (define-syntax define-memoized/v
 548   (lambda (form)
 549     "Define a memoized single-valued unary procedure with docstring.
 550 The procedure argument is compared to cached keys using `eqv?'."
 551     (syntax-case form ()
 552       ((_ (proc arg) docstring body body* ...)
 553        (string? (syntax->datum #'docstring))
 554        #'(define proc
 555            (let ((cache (make-hash-table)))
 556              (define (proc arg)
 557                docstring
 558                (match (hashv-get-handle cache arg)
 559                  ((_ . value)
 560                   value)
 561                  (_
 562                   (let ((result (let () body body* ...)))
 563                     (hashv-set! cache arg result)
 564                     result))))
 565              proc))))))
 566
 567 (define-memoized/v (package-transitive-supported-systems package)
 568   "Return the intersection of the systems supported by PACKAGE and those
 569 supported by its dependencies."
 570   (fold (lambda (input systems)
 571           (match input
 572             ((label (? package? p) . _)
 573              (lset-intersection
 574               string=? systems (package-transitive-supported-systems p)))
 575             (_
 576              systems)))
 577         (package-supported-systems package)
 578         (package-direct-inputs package)))
 579
 580 (define (bag-transitive-inputs bag)
 581   "Same as 'package-transitive-inputs', but applied to a bag."
 582   (transitive-inputs (append (bag-build-inputs bag)
 583                              (bag-host-inputs bag)
 584                              (bag-target-inputs bag))))
 585
 586 (define (bag-transitive-build-inputs bag)
 587   "Same as 'package-transitive-native-inputs', but applied to a bag."
 588   (transitive-inputs (bag-build-inputs bag)))
 589
 590 (define (bag-transitive-host-inputs bag)
 591   "Same as 'package-transitive-target-inputs', but applied to a bag."
 592   (transitive-inputs (bag-host-inputs bag)))
 593
 594 (define (bag-transitive-target-inputs bag)
 595   "Return the \"target inputs\" of BAG, recursively."
 596   (transitive-inputs (bag-target-inputs bag)))
 597
 598 \f
 599 ;;;
 600 ;;; Package derivations.
 601 ;;;
 602
 603 (define %derivation-cache
 604   ;; Package to derivation-path mapping.
 605   (make-weak-key-hash-table 100))
 606
 607 (define (cache package system thunk)
 608   "Memoize the return values of THUNK as the derivation of PACKAGE on
 609 SYSTEM."
 610   ;; FIXME: This memoization should be associated with the open store, because
 611   ;; otherwise it breaks when switching to a different store.
 612   (let ((vals (call-with-values thunk list)))
 613     ;; Use `hashq-set!' instead of `hash-set!' because `hash' returns the
 614     ;; same value for all structs (as of Guile 2.0.6), and because pointer
 615     ;; equality is sufficient in practice.
 616     (hashq-set! %derivation-cache package
 617                 `((,system ,@vals)
 618                   ,@(or (hashq-ref %derivation-cache package)
 619                         '())))
 620     (apply values vals)))
 621
 622 (define-syntax-rule (cached package system body ...)
 623   "Memoize the result of BODY for the arguments PACKAGE and SYSTEM.
 624 Return the cached result when available."
 625   (let ((thunk (lambda () body ...))
 626         (key   system))
 627     (match (hashq-ref %derivation-cache package)
 628       ((alist (... ...))
 629        (match (assoc-ref alist key)
 630          ((vals (... ...))
 631           (apply values vals))
 632          (#f
 633           (cache package key thunk))))
 634       (#f
 635        (cache package key thunk)))))
 636
 637 (define* (expand-input store package input system #:optional cross-system)
 638   "Expand INPUT, an input tuple, such that it contains only references to
 639 derivation paths or store paths.  PACKAGE is only used to provide contextual
 640 information in exceptions."
 641   (define (intern file)
 642     ;; Add FILE to the store.  Set the `recursive?' bit to #t, so that
 643     ;; file permissions are preserved.
 644     (add-to-store store (basename file) #t "sha256" file))
 645
 646   (define derivation
 647     (if cross-system
 648         (cut package-cross-derivation store <> cross-system system
 649              #:graft? #f)
 650         (cut package-derivation store <> system #:graft? #f)))
 651
 652   (match input
 653     (((? string? name) (? package? package))
 654      (list name (derivation package)))
 655     (((? string? name) (? package? package)
 656       (? string? sub-drv))
 657      (list name (derivation package)
 658            sub-drv))
 659     (((? string? name)
 660       (and (? string?) (? derivation-path?) drv))
 661      (list name drv))
 662     (((? string? name)
 663       (and (? string?) (? file-exists? file)))
 664      ;; Add FILE to the store.  When FILE is in the sub-directory of a
 665      ;; store path, it needs to be added anyway, so it can be used as a
 666      ;; source.
 667      (list name (intern file)))
 668     (((? string? name) (? origin? source))
 669      (list name (package-source-derivation store source system)))
 670     (x
 671      (raise (condition (&package-input-error
 672                         (package package)
 673                         (input   x)))))))
 674
 675 (define %graft?
 676   ;; Whether to honor package grafts by default.
 677   (make-parameter #t))
 678
 679 (define* (package->bag package #:optional
 680                        (system (%current-system))
 681                        (target (%current-target-system))
 682                        #:key (graft? (%graft?)))
 683   "Compile PACKAGE into a bag for SYSTEM, possibly cross-compiled to TARGET,
 684 and return it."
 685   ;; Bind %CURRENT-SYSTEM and %CURRENT-TARGET-SYSTEM so that thunked field
 686   ;; values can refer to it.
 687   (parameterize ((%current-system system)
 688                  (%current-target-system target))
 689     (match (if graft?
 690                (or (package-replacement package) package)
 691                package)
 692       (($ <package> name version source build-system
 693                     args inputs propagated-inputs native-inputs self-native-input?
 694                     outputs)
 695        (or (make-bag build-system (string-append name "-" version)
 696                      #:system system
 697                      #:target target
 698                      #:source source
 699                      #:inputs (append (inputs)
 700                                       (propagated-inputs))
 701                      #:outputs outputs
 702                      #:native-inputs `(,@(if (and target self-native-input?)
 703                                              `(("self" ,package))
 704                                              '())
 705                                        ,@(native-inputs))
 706                      #:arguments (args))
 707            (raise (if target
 708                       (condition
 709                        (&package-cross-build-system-error
 710                         (package package)))
 711                       (condition
 712                        (&package-error
 713                         (package package))))))))))
 714
 715 (define (input-graft store system)
 716   "Return a procedure that, given an input referring to a package with a
 717 graft, returns a pair with the original derivation and the graft's derivation,
 718 and returns #f for other inputs."
 719   (match-lambda
 720    ((label (? package? package) sub-drv ...)
 721     (let ((replacement (package-replacement package)))
 722       (and replacement
 723            (let ((orig (package-derivation store package system
 724                                            #:graft? #f))
 725                  (new  (package-derivation store replacement system)))
 726              (graft
 727                (origin orig)
 728                (replacement new)
 729                (origin-output (match sub-drv
 730                                 (() "out")
 731                                 ((output) output)))
 732                (replacement-output origin-output))))))
 733    (x
 734     #f)))
 735
 736 (define (input-cross-graft store target system)
 737   "Same as 'input-graft', but for cross-compilation inputs."
 738   (match-lambda
 739    ((label (? package? package) sub-drv ...)
 740     (let ((replacement (package-replacement package)))
 741       (and replacement
 742            (let ((orig (package-cross-derivation store package target system
 743                                                  #:graft? #f))
 744                  (new  (package-cross-derivation store replacement
 745                                                  target system)))
 746              (graft
 747                (origin orig)
 748                (replacement new)
 749                (origin-output (match sub-drv
 750                                 (() "out")
 751                                 ((output) output)))
 752                (replacement-output origin-output))))))
 753    (_
 754     #f)))
 755
 756 (define* (bag-grafts store bag)
 757   "Return the list of grafts applicable to BAG.  Each graft is a <graft>
 758 record."
 759   (let ((target (bag-target bag))
 760         (system (bag-system bag)))
 761     (define native-grafts
 762       (filter-map (input-graft store system)
 763                   (append (bag-transitive-build-inputs bag)
 764                           (bag-transitive-target-inputs bag)
 765                           (if target
 766                               '()
 767                               (bag-transitive-host-inputs bag)))))
 768
 769     (define target-grafts
 770       (if target
 771           (filter-map (input-cross-graft store target system)
 772                       (bag-transitive-host-inputs bag))
 773           '()))
 774
 775     (append native-grafts target-grafts)))
 776
 777 (define* (package-grafts store package
 778                          #:optional (system (%current-system))
 779                          #:key target)
 780   "Return the list of grafts applicable to PACKAGE as built for SYSTEM and
 781 TARGET."
 782   (let* ((package (or (package-replacement package) package))
 783          (bag     (package->bag package system target)))
 784     (bag-grafts store bag)))
 785
 786 (define* (bag->derivation store bag
 787                           #:optional context)
 788   "Return the derivation to build BAG for SYSTEM.  Optionally, CONTEXT can be
 789 a package object describing the context in which the call occurs, for improved
 790 error reporting."
 791   (if (bag-target bag)
 792       (bag->cross-derivation store bag)
 793       (let* ((system     (bag-system bag))
 794              (inputs     (bag-transitive-inputs bag))
 795              (input-drvs (map (cut expand-input store context <> system)
 796                               inputs))
 797              (paths      (delete-duplicates
 798                           (append-map (match-lambda
 799                                        ((_ (? package? p) _ ...)
 800                                         (package-native-search-paths
 801                                          p))
 802                                        (_ '()))
 803                                       inputs))))
 804
 805         (apply (bag-build bag)
 806                store (bag-name bag) input-drvs
 807                #:search-paths paths
 808                #:outputs (bag-outputs bag) #:system system
 809                (bag-arguments bag)))))
 810
 811 (define* (bag->cross-derivation store bag
 812                                 #:optional context)
 813   "Return the derivation to build BAG, which is actually a cross build.
 814 Optionally, CONTEXT can be a package object denoting the context of the call.
 815 This is an internal procedure."
 816   (let* ((system      (bag-system bag))
 817          (target      (bag-target bag))
 818          (host        (bag-transitive-host-inputs bag))
 819          (host-drvs   (map (cut expand-input store context <> system target)
 820                            host))
 821          (target*     (bag-transitive-target-inputs bag))
 822          (target-drvs (map (cut expand-input store context <> system)
 823                            target*))
 824          (build       (bag-transitive-build-inputs bag))
 825          (build-drvs  (map (cut expand-input store context <> system)
 826                            build))
 827          (all         (append build target* host))
 828          (paths       (delete-duplicates
 829                        (append-map (match-lambda
 830                                     ((_ (? package? p) _ ...)
 831                                      (package-search-paths p))
 832                                     (_ '()))
 833                                    all)))
 834          (npaths      (delete-duplicates
 835                        (append-map (match-lambda
 836                                     ((_ (? package? p) _ ...)
 837                                      (package-native-search-paths
 838                                       p))
 839                                     (_ '()))
 840                                    all))))
 841
 842     (apply (bag-build bag)
 843            store (bag-name bag)
 844            #:native-drvs build-drvs
 845            #:target-drvs (append host-drvs target-drvs)
 846            #:search-paths paths
 847            #:native-search-paths npaths
 848            #:outputs (bag-outputs bag)
 849            #:system system #:target target
 850            (bag-arguments bag))))
 851
 852 (define* (package-derivation store package
 853                              #:optional (system (%current-system))
 854                              #:key (graft? (%graft?)))
 855   "Return the <derivation> object of PACKAGE for SYSTEM."
 856
 857   ;; Compute the derivation and cache the result.  Caching is important
 858   ;; because some derivations, such as the implicit inputs of the GNU build
 859   ;; system, will be queried many, many times in a row.
 860   (cached package (cons system graft?)
 861           (let* ((bag (package->bag package system #f #:graft? graft?))
 862                  (drv (bag->derivation store bag package)))
 863             (if graft?
 864                 (match (bag-grafts store bag)
 865                   (()
 866                    drv)
 867                   (grafts
 868                    (let ((guile (package-derivation store (default-guile)
 869                                                     system #:graft? #f)))
 870                      (graft-derivation store (bag-name bag) drv grafts
 871                                        #:system system
 872                                        #:guile guile))))
 873                 drv))))
 874
 875 (define* (package-cross-derivation store package target
 876                                    #:optional (system (%current-system))
 877                                    #:key (graft? (%graft?)))
 878   "Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix
 879 system identifying string)."
 880   (cached package (list system target graft?)
 881           (let* ((bag (package->bag package system target #:graft? graft?))
 882                  (drv (bag->derivation store bag package)))
 883             (if graft?
 884                 (match (bag-grafts store bag)
 885                   (()
 886                    drv)
 887                   (grafts
 888                    (graft-derivation store (bag-name bag) drv grafts
 889                                      #:system system
 890                                      #:guile
 891                                      (package-derivation store (default-guile)
 892                                                          system #:graft? #f))))
 893                 drv))))
 894
 895 (define* (package-output store package
 896                          #:optional (output "out") (system (%current-system)))
 897   "Return the output path of PACKAGE's OUTPUT for SYSTEM---where OUTPUT is the
 898 symbolic output name, such as \"out\".  Note that this procedure calls
 899 `package-derivation', which is costly."
 900   (let ((drv (package-derivation store package system)))
 901     (derivation->output-path drv output)))