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