guix/packages.scm

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