1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2014, 2015 Mark H Weaver <mhw@netris.org>
4 ;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
5 ;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
7 ;;; This file is part of GNU Guix.
9 ;;; GNU Guix is free software; you can redistribute it and/or modify it
10 ;;; under the terms of the GNU General Public License as published by
11 ;;; the Free Software Foundation; either version 3 of the License, or (at
12 ;;; your option) any later version.
14 ;;; GNU Guix is distributed in the hope that it will be useful, but
15 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;;; GNU General Public License for more details.
19 ;;; You should have received a copy of the GNU General Public License
20 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
22 (define-module (guix packages)
23 #:use-module (guix utils)
24 #:use-module (guix records)
25 #:use-module (guix store)
26 #:use-module (guix monads)
27 #:use-module (guix gexp)
28 #:use-module (guix base32)
29 #:use-module (guix grafts)
30 #:use-module (guix derivations)
31 #:use-module (guix build-system)
32 #:use-module (guix search-paths)
33 #:use-module (guix gexp)
34 #:use-module (guix sets)
35 #:use-module (ice-9 match)
36 #:use-module (ice-9 vlist)
37 #:use-module (srfi srfi-1)
38 #:use-module (srfi srfi-9 gnu)
39 #:use-module (srfi srfi-11)
40 #:use-module (srfi srfi-26)
41 #:use-module (srfi srfi-34)
42 #:use-module (srfi srfi-35)
43 #:use-module (web uri)
44 #:re-export (%current-system
45 %current-target-system
46 search-path-specification) ;for convenience
53 origin-actual-file-name
72 package-propagated-inputs
74 package-native-search-paths
81 package-supported-systems
89 package-field-location
91 package-direct-sources
92 package-transitive-sources
94 package-transitive-inputs
95 package-transitive-target-inputs
96 package-transitive-native-inputs
97 package-transitive-propagated-inputs
98 package-transitive-native-search-paths
99 package-transitive-supported-systems
100 package-input-rewriting
101 package-source-derivation
103 package-cross-derivation
107 transitive-input-references
111 %hydra-supported-systems
116 package-error-package
119 package-error-invalid-input
120 &package-cross-build-system-error
121 package-cross-build-system-error?
126 bag-transitive-inputs
127 bag-transitive-host-inputs
128 bag-transitive-build-inputs
129 bag-transitive-target-inputs
132 default-guile-derivation
136 package->cross-derivation
141 ;;; This module provides a high-level mechanism to define packages in a
142 ;;; Guix-based distribution.
146 ;; The source of a package, such as a tarball URL and fetcher---called
147 ;; "origin" to avoid name clash with `package-source', `source', etc.
148 (define-record-type* <origin>
151 (uri origin-uri) ; string
152 (method origin-method) ; procedure
153 (sha256 origin-sha256) ; bytevector
154 (file-name origin-file-name (default #f)) ; optional file name
156 ;; Patches are delayed so that the 'search-patch' calls are made lazily,
157 ;; which reduces I/O on startup and allows patch-not-found errors to be
158 ;; gracefully handled at run time.
159 (patches origin-patches ; list of file names
160 (default '()) (delayed))
162 (snippet origin-snippet (default #f)) ; sexp or #f
163 (patch-flags origin-patch-flags ; list of strings
166 ;; Patching requires Guile, GNU Patch, and a few more. These two fields are
167 ;; used to specify these dependencies when needed.
168 (patch-inputs origin-patch-inputs ; input list or #f
170 (modules origin-modules ; list of module names
173 (patch-guile origin-patch-guile ; package or #f
176 (define (print-origin origin port)
177 "Write a concise representation of ORIGIN to PORT."
179 (($ <origin> uri method sha256 file-name patches)
180 (simple-format port "#<origin ~s ~a ~s ~a>"
181 uri (bytevector->base32-string sha256)
183 (number->string (object-address origin) 16)))))
185 (set-record-type-printer! <origin> print-origin)
187 (define-syntax base32
189 "Return the bytevector corresponding to the given Nix-base32
193 (string? (syntax->datum #'str))
194 ;; A literal string: do the conversion at expansion time.
195 (with-syntax ((bv (nix-base32-string->bytevector
196 (syntax->datum #'str))))
199 #'(nix-base32-string->bytevector str)))))
201 (define (origin-actual-file-name origin)
202 "Return the file name of ORIGIN, either its 'file-name' field or the file
204 (define (uri->file-name uri)
205 ;; Return the 'base name' of URI or URI itself, where URI is a string.
206 (let ((path (and=> (string->uri uri) uri-path)))
211 (or (origin-file-name origin)
212 (match (origin-uri origin)
214 (uri->file-name head))
216 (uri->file-name uri))
218 ;; git, svn, cvs, etc. reference
221 (define %supported-systems
222 ;; This is the list of system types that are supported. By default, we
223 ;; expect all packages to build successfully here.
224 '("x86_64-linux" "i686-linux" "armhf-linux" "mips64el-linux"))
226 (define %hurd-systems
227 ;; The GNU/Hurd systems for which support is being developed.
228 '("i585-gnu" "i686-gnu"))
230 (define %hydra-supported-systems
231 ;; This is the list of system types for which build slaves are available.
236 (define-record-type* <package>
239 (name package-name) ; string
240 (version package-version) ; string
241 (source package-source) ; <origin> instance
242 (build-system package-build-system) ; build system
243 (arguments package-arguments ; arguments for the build method
244 (default '()) (thunked))
246 (inputs package-inputs ; input packages or derivations
247 (default '()) (thunked))
248 (propagated-inputs package-propagated-inputs ; same, but propagated
249 (default '()) (thunked))
250 (native-inputs package-native-inputs ; native input packages/derivations
251 (default '()) (thunked))
252 (self-native-input? package-self-native-input? ; whether to use itself as
253 ; a native input when cross-
254 (default #f)) ; compiling
256 (outputs package-outputs ; list of strings
260 ; <search-path-specification>,
261 ; for native and cross
263 (native-search-paths package-native-search-paths (default '()))
264 (search-paths package-search-paths (default '()))
265 (replacement package-replacement ; package | #f
266 (default #f) (thunked))
268 (synopsis package-synopsis) ; one-line description
269 (description package-description) ; one or two paragraphs
270 (license package-license)
271 (home-page package-home-page)
272 (supported-systems package-supported-systems ; list of strings
273 (default %supported-systems))
274 (maintainers package-maintainers (default '()))
276 (properties package-properties (default '())) ; alist for anything else
278 (location package-location
279 (default (and=> (current-source-location)
280 source-properties->location))
283 (set-record-type-printer! <package>
284 (lambda (package port)
285 (let ((loc (package-location package))
286 (format simple-format))
287 (format port "#<package ~a@~a ~a~a>"
288 (package-name package)
289 (package-version package)
295 (number->string (object-address
299 (define (hidden-package p)
300 "Return a \"hidden\" version of P--i.e., one that 'fold-packages' and thus,
301 user interfaces, ignores."
304 (properties `((hidden? . #t)
305 ,@(package-properties p)))))
307 (define (hidden-package? p)
308 "Return true if P is \"hidden\"--i.e., must not be visible to user
310 (assoc-ref (package-properties p) 'hidden?))
312 (define (package-superseded p)
313 "Return the package the supersedes P, or #f if P is still current."
314 (assoc-ref (package-properties p) 'superseded))
316 (define (deprecated-package old-name p)
317 "Return a package called OLD-NAME and marked as superseded by P, a package
322 (properties `((superseded . ,p)))))
324 (define (package-field-location package field)
325 "Return the source code location of the definition of FIELD for PACKAGE, or
326 #f if it could not be determined."
327 (define (goto port line column)
328 (unless (and (= (port-column port) (- column 1))
329 (= (port-line port) (- line 1)))
330 (unless (eof-object? (read-char port))
331 (goto port line column))))
333 (match (package-location package)
334 (($ <location> file line column)
337 ;; In general we want to keep relative file names for modules.
338 (with-fluids ((%file-port-name-canonicalization 'relative))
339 (call-with-input-file (search-path %load-path file)
341 (goto port line column)
343 (('package inits ...)
344 (let ((field (assoc field inits)))
347 ;; Put the `or' here, and not in the first argument of
348 ;; `and=>', to work around a compiler bug in 2.0.5.
349 (or (and=> (source-properties value)
350 source-properties->location)
351 (and=> (source-properties field)
352 source-properties->location)))
364 (define-condition-type &package-error &error
366 (package package-error-package))
368 (define-condition-type &package-input-error &package-error
370 (input package-error-invalid-input))
372 (define-condition-type &package-cross-build-system-error &package-error
373 package-cross-build-system-error?)
376 (define (package-full-name package)
377 "Return the full name of PACKAGE--i.e., `NAME-VERSION'."
378 (string-append (package-name package) "-" (package-version package)))
380 (define (%standard-patch-inputs)
381 (let* ((canonical (module-ref (resolve-interface '(gnu packages base))
383 (ref (lambda (module var)
385 (module-ref (resolve-interface module) var)))))
386 `(("tar" ,(ref '(gnu packages base) 'tar))
387 ("xz" ,(ref '(gnu packages compression) 'xz))
388 ("bzip2" ,(ref '(gnu packages compression) 'bzip2))
389 ("gzip" ,(ref '(gnu packages compression) 'gzip))
390 ("lzip" ,(ref '(gnu packages compression) 'lzip))
391 ("unzip" ,(ref '(gnu packages zip) 'unzip))
392 ("patch" ,(ref '(gnu packages base) 'patch))
393 ("locales" ,(ref '(gnu packages base) 'glibc-utf8-locales)))))
395 (define (default-guile)
396 "Return the default Guile package used to run the build code of
398 (let ((distro (resolve-interface '(gnu packages commencement))))
399 (module-ref distro 'guile-final)))
401 (define* (default-guile-derivation #:optional (system (%current-system)))
402 "Return the derivation for SYSTEM of the default Guile package used to run
403 the build code of derivation."
404 (package->derivation (default-guile) system
407 (define* (patch-and-repack source patches
413 (guile-for-build (%guile-for-build))
414 (system (%current-system)))
415 "Unpack SOURCE (a derivation or store path), apply all of PATCHES, and
416 repack the tarball using the tools listed in INPUTS. When SNIPPET is true,
417 it must be an s-expression that will run from within the directory where
418 SOURCE was unpacked, after all of PATCHES have been applied. MODULES
419 specifies modules in scope when evaluating SNIPPET."
420 (define source-file-name
421 ;; SOURCE is usually a derivation, but it could be a store file.
422 (if (derivation? source)
423 (derivation->output-path source)
427 ;; The default value of the 'patch-inputs' field, and thus INPUTS is #f,
428 ;; so deal with that.
429 (let ((inputs (or inputs (%standard-patch-inputs))))
431 (match (assoc-ref inputs name)
435 (define decompression-type
436 (cond ((string-suffix? "gz" source-file-name) "gzip")
437 ((string-suffix? "Z" source-file-name) "gzip")
438 ((string-suffix? "bz2" source-file-name) "bzip2")
439 ((string-suffix? "lz" source-file-name) "lzip")
440 ((string-suffix? "zip" source-file-name) "unzip")
443 (define original-file-name
444 ;; Remove the store prefix plus the slash, hash, and hyphen.
445 (let* ((sans (string-drop source-file-name
446 (+ (string-length (%store-prefix)) 1)))
447 (dash (string-index sans #\-)))
448 (string-drop sans (+ 1 dash))))
450 (define (numeric-extension? file-name)
451 ;; Return true if FILE-NAME ends with digits.
452 (and=> (file-extension file-name)
453 (cut string-every char-set:hex-digit <>)))
455 (define (tarxz-name file-name)
456 ;; Return a '.tar.xz' file name based on FILE-NAME.
457 (let ((base (if (numeric-extension? file-name)
459 (file-sans-extension file-name))))
461 (if (equal? (file-extension base) "tar")
465 (define instantiate-patch
468 (interned-file patch #:recursive? #t))
470 (origin->derivation patch system))))
472 (mlet %store-monad ((tar -> (lookup-input "tar"))
473 (xz -> (lookup-input "xz"))
474 (patch -> (lookup-input "patch"))
475 (locales -> (lookup-input "locales"))
476 (decomp -> (lookup-input decompression-type))
477 (patches (sequence %store-monad
478 (map instantiate-patch patches))))
480 (with-imported-modules '((guix build utils))
482 (use-modules (ice-9 ftw)
486 ;; The --sort option was added to GNU tar in version 1.28, released
487 ;; 2014-07-28. During bootstrap we must cope with older versions.
488 (define tar-supports-sort?
489 (zero? (system* (string-append #+tar "/bin/tar")
490 "cf" "/dev/null" "--files-from=/dev/null"
493 (define (apply-patch patch)
494 (format (current-error-port) "applying '~a'...~%" patch)
496 ;; Use '--force' so that patches that do not apply perfectly are
497 ;; rejected. Use '--no-backup-if-mismatch' to prevent making
498 ;; "*.orig" file if a patch is applied with offset.
499 (zero? (system* (string-append #+patch "/bin/patch")
500 "--force" "--no-backup-if-mismatch"
501 #+@flags "--input" patch)))
503 (define (first-file directory)
504 ;; Return the name of the first file in DIRECTORY.
505 (car (scandir directory
507 (not (member name '("." "..")))))))
509 ;; Encoding/decoding errors shouldn't be silent.
510 (fluid-set! %default-port-conversion-strategy 'error)
513 ;; First of all, install a UTF-8 locale so that UTF-8 file names
514 ;; are correctly interpreted. During bootstrap, LOCALES is #f.
516 (string-append #+locales "/lib/locale/"
518 (package-version locales))))
519 (setlocale LC_ALL "en_US.utf8"))
521 (setenv "PATH" (string-append #+xz "/bin" ":"
524 ;; SOURCE may be either a directory or a tarball.
525 (and (if (file-is-directory? #+source)
526 (let* ((store (%store-directory))
527 (len (+ 1 (string-length store)))
528 (base (string-drop #+source len))
529 (dash (string-index base #\-))
530 (directory (string-drop base (+ 1 dash))))
532 (copy-recursively #+source directory)
534 #+(if (string=? decompression-type "unzip")
535 #~(zero? (system* "unzip" #+source))
536 #~(zero? (system* (string-append #+tar "/bin/tar")
538 (let ((directory (first-file ".")))
539 (format (current-error-port)
540 "source is under '~a'~%" directory)
543 (and (every apply-patch '#+patches)
545 #~((let ((module (make-fresh-user-module)))
546 (module-use-interfaces!
548 (map resolve-interface '#+modules))
549 ((@ (system base compile) compile)
552 #:opts %auto-compilation-options
556 (begin (chdir "..") #t)
558 (unless tar-supports-sort?
559 (call-with-output-file ".file_list"
561 (for-each (lambda (name)
562 (format port "~a~%" name))
563 (find-files directory
565 #:fail-on-error? #t)))))
566 (zero? (apply system*
567 (string-append #+tar "/bin/tar")
569 ;; avoid non-determinism in the archive
573 (if tar-supports-sort?
577 "--files-from=.file_list"))))))))))
579 (let ((name (tarxz-name original-file-name)))
580 (gexp->derivation name build
583 #:guile-for-build guile-for-build))))
585 (define (transitive-inputs inputs)
586 "Return the closure of INPUTS when considering the 'propagated-inputs'
587 edges. Omit duplicate inputs, except for those already present in INPUTS
590 This is implemented as a breadth-first traversal such that INPUTS is
591 preserved, and only duplicate propagated inputs are removed."
592 (define (seen? seen item outputs)
593 (match (vhash-assq item seen)
594 ((_ . o) (equal? o outputs))
597 (let loop ((inputs inputs)
604 (if (null? propagated)
606 (loop (reverse (concatenate propagated)) result '() #f seen)))
607 (((and input (label (? package? package) outputs ...)) rest ...)
608 (if (and (not first?) (seen? seen package outputs))
609 (loop rest result propagated first? seen)
612 (cons (package-propagated-inputs package) propagated)
614 (vhash-consq package outputs seen))))
616 (loop rest (cons input result) propagated first? seen)))))
618 (define (package-direct-sources package)
619 "Return all source origins associated with PACKAGE; including origins in
621 `(,@(or (and=> (package-source package) list) '())
622 ,@(filter-map (match-lambda
623 ((_ (? origin? orig) _ ...)
626 (package-direct-inputs package))))
628 (define (package-transitive-sources package)
629 "Return PACKAGE's direct sources, and their direct sources, recursively."
631 (concatenate (filter-map (match-lambda
632 ((_ (? origin? orig) _ ...)
634 ((_ (? package? p) _ ...)
635 (package-direct-sources p))
637 (bag-transitive-inputs
638 (package->bag package))))))
640 (define (package-direct-inputs package)
641 "Return all the direct inputs of PACKAGE---i.e, its direct inputs along
642 with their propagated inputs."
643 (append (package-native-inputs package)
644 (package-inputs package)
645 (package-propagated-inputs package)))
647 (define (package-transitive-inputs package)
648 "Return the transitive inputs of PACKAGE---i.e., its direct inputs along
649 with their propagated inputs, recursively."
650 (transitive-inputs (package-direct-inputs package)))
652 (define (package-transitive-target-inputs package)
653 "Return the transitive target inputs of PACKAGE---i.e., its direct inputs
654 along with their propagated inputs, recursively. This only includes inputs
655 for the target system, and not native inputs."
656 (transitive-inputs (append (package-inputs package)
657 (package-propagated-inputs package))))
659 (define (package-transitive-native-inputs package)
660 "Return the transitive native inputs of PACKAGE---i.e., its direct inputs
661 along with their propagated inputs, recursively. This only includes inputs
662 for the host system (\"native inputs\"), and not target inputs."
663 (transitive-inputs (package-native-inputs package)))
665 (define (package-transitive-propagated-inputs package)
666 "Return the propagated inputs of PACKAGE, and their propagated inputs,
668 (transitive-inputs (package-propagated-inputs package)))
670 (define (package-transitive-native-search-paths package)
671 "Return the list of search paths for PACKAGE and its propagated inputs,
673 (append (package-native-search-paths package)
674 (append-map (match-lambda
675 ((label (? package? p) _ ...)
676 (package-native-search-paths p))
679 (package-transitive-propagated-inputs package))))
681 (define (transitive-input-references alist inputs)
682 "Return a list of (assoc-ref ALIST <label>) for each (<label> <package> . _)
683 in INPUTS and their transitive propagated inputs."
690 `(assoc-ref ,alist ,(label input)))
691 (transitive-inputs inputs)))
693 (define-syntax define-memoized/v
695 "Define a memoized single-valued unary procedure with docstring.
696 The procedure argument is compared to cached keys using `eqv?'."
698 ((_ (proc arg) docstring body body* ...)
699 (string? (syntax->datum #'docstring))
701 (let ((cache (make-hash-table)))
704 (match (hashv-get-handle cache arg)
708 (let ((result (let () body body* ...)))
709 (hashv-set! cache arg result)
713 (define-memoized/v (package-transitive-supported-systems package)
714 "Return the intersection of the systems supported by PACKAGE and those
715 supported by its dependencies."
716 (fold (lambda (input systems)
718 ((label (? package? p) . _)
720 string=? systems (package-transitive-supported-systems p)))
723 (package-supported-systems package)
724 (bag-direct-inputs (package->bag package))))
726 (define* (supported-package? package #:optional (system (%current-system)))
727 "Return true if PACKAGE is supported on SYSTEM--i.e., if PACKAGE and all its
728 dependencies are known to build on SYSTEM."
729 (member system (package-transitive-supported-systems package)))
731 (define (bag-direct-inputs bag)
732 "Same as 'package-direct-inputs', but applied to a bag."
733 (append (bag-build-inputs bag)
734 (bag-host-inputs bag)
735 (bag-target-inputs bag)))
737 (define (bag-transitive-inputs bag)
738 "Same as 'package-transitive-inputs', but applied to a bag."
739 (transitive-inputs (bag-direct-inputs bag)))
741 (define (bag-transitive-build-inputs bag)
742 "Same as 'package-transitive-native-inputs', but applied to a bag."
743 (transitive-inputs (bag-build-inputs bag)))
745 (define (bag-transitive-host-inputs bag)
746 "Same as 'package-transitive-target-inputs', but applied to a bag."
747 (transitive-inputs (bag-host-inputs bag)))
749 (define (bag-transitive-target-inputs bag)
750 "Return the \"target inputs\" of BAG, recursively."
751 (transitive-inputs (bag-target-inputs bag)))
753 (define* (package-input-rewriting replacements
754 #:optional (rewrite-name identity))
755 "Return a procedure that, when passed a package, replaces its direct and
756 indirect dependencies (but not its implicit inputs) according to REPLACEMENTS.
757 REPLACEMENTS is a list of package pairs; the first element of each pair is the
758 package to replace, and the second one is the replacement.
760 Optionally, REWRITE-NAME is a one-argument procedure that takes the name of a
761 package and returns its new name after rewrite."
762 (define (rewrite input)
764 ((label (? package? package) outputs ...)
765 (match (assq-ref replacements package)
766 (#f (cons* label (replace package) outputs))
767 (new (cons* label new outputs))))
771 (define-memoized/v (replace p)
772 "Return a variant of P with its inputs rewritten."
775 (name (rewrite-name (package-name p)))
776 (inputs (map rewrite (package-inputs p)))
777 (native-inputs (map rewrite (package-native-inputs p)))
778 (propagated-inputs (map rewrite (package-propagated-inputs p)))))
784 ;;; Package derivations.
787 (define %derivation-cache
788 ;; Package to derivation-path mapping.
789 (make-weak-key-hash-table 100))
791 (define (cache! cache package system thunk)
792 "Memoize in CACHE the return values of THUNK as the derivation of PACKAGE on
794 ;; FIXME: This memoization should be associated with the open store, because
795 ;; otherwise it breaks when switching to a different store.
796 (let ((vals (call-with-values thunk list)))
797 ;; Use `hashq-set!' instead of `hash-set!' because `hash' returns the
798 ;; same value for all structs (as of Guile 2.0.6), and because pointer
799 ;; equality is sufficient in practice.
800 (hashq-set! cache package
802 ,@(or (hashq-ref cache package) '())))
803 (apply values vals)))
805 (define-syntax cached
807 "Memoize the result of BODY for the arguments PACKAGE and SYSTEM.
808 Return the cached result when available."
809 ((_ (=> cache) package system body ...)
810 (let ((thunk (lambda () body ...))
812 (match (hashq-ref cache package)
814 (match (assoc-ref alist key)
818 (cache! cache package key thunk))))
820 (cache! cache package key thunk)))))
821 ((_ package system body ...)
822 (cached (=> %derivation-cache) package system body ...))))
824 (define* (expand-input store package input system #:optional cross-system)
825 "Expand INPUT, an input tuple, such that it contains only references to
826 derivation paths or store paths. PACKAGE is only used to provide contextual
827 information in exceptions."
828 (define (intern file)
829 ;; Add FILE to the store. Set the `recursive?' bit to #t, so that
830 ;; file permissions are preserved.
831 (add-to-store store (basename file) #t "sha256" file))
835 (cut package-cross-derivation store <> cross-system system
837 (cut package-derivation store <> system #:graft? #f)))
840 (((? string? name) (? package? package))
841 (list name (derivation package)))
842 (((? string? name) (? package? package)
844 (list name (derivation package)
847 (and (? string?) (? derivation-path?) drv))
850 (and (? string?) (? file-exists? file)))
851 ;; Add FILE to the store. When FILE is in the sub-directory of a
852 ;; store path, it needs to be added anyway, so it can be used as a
854 (list name (intern file)))
855 (((? string? name) (? struct? source))
856 (list name (package-source-derivation store source system)))
858 (raise (condition (&package-input-error
863 ;; 'eq?' cache mapping packages to system+target+graft?-dependent bags.
864 ;; It significantly speeds things up when doing repeated calls to
865 ;; 'package->bag' as is the case when building a profile.
866 (make-weak-key-hash-table 200))
868 (define* (package->bag package #:optional
869 (system (%current-system))
870 (target (%current-target-system))
871 #:key (graft? (%graft?)))
872 "Compile PACKAGE into a bag for SYSTEM, possibly cross-compiled to TARGET,
874 (cached (=> %bag-cache)
875 package (list system target graft?)
876 ;; Bind %CURRENT-SYSTEM and %CURRENT-TARGET-SYSTEM so that thunked
877 ;; field values can refer to it.
878 (parameterize ((%current-system system)
879 (%current-target-system target))
881 (or (package-replacement package) package)
883 (($ <package> name version source build-system
884 args inputs propagated-inputs native-inputs
885 self-native-input? outputs)
886 (or (make-bag build-system (string-append name "-" version)
890 #:inputs (append (inputs)
893 #:native-inputs `(,@(if (and target
901 (&package-cross-build-system-error
905 (package package)))))))))))
908 ;; 'eq?' cache mapping package objects to a graft corresponding to their
909 ;; replacement package.
910 (make-weak-key-hash-table 200))
912 (define (input-graft store system)
913 "Return a procedure that, given a package with a graft, returns a graft, and
916 ((? package? package)
917 (let ((replacement (package-replacement package)))
919 (cached (=> %graft-cache) package system
920 (let ((orig (package-derivation store package system
922 (new (package-derivation store replacement system
926 (replacement new)))))))
930 (define (input-cross-graft store target system)
931 "Same as 'input-graft', but for cross-compilation inputs."
933 ((? package? package)
934 (let ((replacement (package-replacement package)))
936 (let ((orig (package-cross-derivation store package target system
938 (new (package-cross-derivation store replacement
943 (replacement new))))))
947 (define* (fold-bag-dependencies proc seed bag
949 "Fold PROC over the packages BAG depends on. Each package is visited only
950 once, in depth-first order. If NATIVE? is true, restrict to native
951 dependencies; otherwise, restrict to target dependencies."
954 (append (bag-build-inputs bag)
955 (bag-target-inputs bag)
958 (bag-host-inputs bag)))
959 (bag-host-inputs bag))
960 (((labels things _ ...) ...)
963 (let loop ((nodes nodes)
969 (((? package? head) . tail)
970 (if (set-contains? visited head)
971 (loop tail result visited)
972 (let ((inputs (bag-direct-inputs (package->bag head))))
974 (((labels things _ ...) ...)
975 (append things tail)))
977 (set-insert head visited)))))
979 (loop tail result visited)))))
981 (define* (bag-grafts store bag)
982 "Return the list of grafts potentially applicable to BAG. Potentially
983 applicable grafts are collected by looking at direct or indirect dependencies
984 of BAG that have a 'replacement'. Whether a graft is actually applicable
985 depends on whether the outputs of BAG depend on the items the grafts refer
986 to (see 'graft-derivation'.)"
987 (define system (bag-system bag))
988 (define target (bag-target bag))
990 (define native-grafts
991 (let ((->graft (input-graft store system)))
992 (fold-bag-dependencies (lambda (package grafts)
993 (match (->graft package)
995 (graft (cons graft grafts))))
999 (define target-grafts
1001 (let ((->graft (input-cross-graft store target system)))
1002 (fold-bag-dependencies (lambda (package grafts)
1003 (match (->graft package)
1005 (graft (cons graft grafts))))
1011 ;; We can end up with several identical grafts if we stumble upon packages
1012 ;; that are not 'eq?' but map to the same derivation (this can happen when
1013 ;; using things like 'package-with-explicit-inputs'.) Hence the
1014 ;; 'delete-duplicates' call.
1016 (append native-grafts target-grafts)))
1018 (define* (package-grafts store package
1019 #:optional (system (%current-system))
1021 "Return the list of grafts applicable to PACKAGE as built for SYSTEM and
1023 (let* ((package (or (package-replacement package) package))
1024 (bag (package->bag package system target)))
1025 (bag-grafts store bag)))
1027 (define* (bag->derivation store bag
1029 "Return the derivation to build BAG for SYSTEM. Optionally, CONTEXT can be
1030 a package object describing the context in which the call occurs, for improved
1032 (if (bag-target bag)
1033 (bag->cross-derivation store bag)
1034 (let* ((system (bag-system bag))
1035 (inputs (bag-transitive-inputs bag))
1036 (input-drvs (map (cut expand-input store context <> system)
1038 (paths (delete-duplicates
1039 (append-map (match-lambda
1040 ((_ (? package? p) _ ...)
1041 (package-native-search-paths
1046 (apply (bag-build bag)
1047 store (bag-name bag) input-drvs
1048 #:search-paths paths
1049 #:outputs (bag-outputs bag) #:system system
1050 (bag-arguments bag)))))
1052 (define* (bag->cross-derivation store bag
1054 "Return the derivation to build BAG, which is actually a cross build.
1055 Optionally, CONTEXT can be a package object denoting the context of the call.
1056 This is an internal procedure."
1057 (let* ((system (bag-system bag))
1058 (target (bag-target bag))
1059 (host (bag-transitive-host-inputs bag))
1060 (host-drvs (map (cut expand-input store context <> system target)
1062 (target* (bag-transitive-target-inputs bag))
1063 (target-drvs (map (cut expand-input store context <> system)
1065 (build (bag-transitive-build-inputs bag))
1066 (build-drvs (map (cut expand-input store context <> system)
1068 (all (append build target* host))
1069 (paths (delete-duplicates
1070 (append-map (match-lambda
1071 ((_ (? package? p) _ ...)
1072 (package-search-paths p))
1075 (npaths (delete-duplicates
1076 (append-map (match-lambda
1077 ((_ (? package? p) _ ...)
1078 (package-native-search-paths
1083 (apply (bag-build bag)
1084 store (bag-name bag)
1085 #:native-drvs build-drvs
1086 #:target-drvs (append host-drvs target-drvs)
1087 #:search-paths paths
1088 #:native-search-paths npaths
1089 #:outputs (bag-outputs bag)
1090 #:system system #:target target
1091 (bag-arguments bag))))
1093 (define* (package-derivation store package
1094 #:optional (system (%current-system))
1095 #:key (graft? (%graft?)))
1096 "Return the <derivation> object of PACKAGE for SYSTEM."
1098 ;; Compute the derivation and cache the result. Caching is important
1099 ;; because some derivations, such as the implicit inputs of the GNU build
1100 ;; system, will be queried many, many times in a row.
1101 (cached package (cons system graft?)
1102 (let* ((bag (package->bag package system #f #:graft? graft?))
1103 (drv (bag->derivation store bag package)))
1105 (match (bag-grafts store bag)
1109 (let ((guile (package-derivation store (default-guile)
1110 system #:graft? #f)))
1111 ;; TODO: As an optimization, we can simply graft the tip
1112 ;; of the derivation graph since 'graft-derivation'
1114 (graft-derivation store drv grafts
1119 (define* (package-cross-derivation store package target
1120 #:optional (system (%current-system))
1121 #:key (graft? (%graft?)))
1122 "Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix
1123 system identifying string)."
1124 (cached package (list system target graft?)
1125 (let* ((bag (package->bag package system target #:graft? graft?))
1126 (drv (bag->derivation store bag package)))
1128 (match (bag-grafts store bag)
1132 (graft-derivation store drv grafts
1135 (package-derivation store (default-guile)
1136 system #:graft? #f))))
1139 (define* (package-output store package
1140 #:optional (output "out") (system (%current-system)))
1141 "Return the output path of PACKAGE's OUTPUT for SYSTEM---where OUTPUT is the
1142 symbolic output name, such as \"out\". Note that this procedure calls
1143 `package-derivation', which is costly."
1144 (let ((drv (package-derivation store package system)))
1145 (derivation->output-path drv output)))
1149 ;;; Monadic interface.
1152 (define (set-guile-for-build guile)
1153 "This monadic procedure changes the Guile currently used to run the build
1154 code of derivations to GUILE, a package object."
1156 (let ((guile (package-derivation store guile)))
1157 (values (%guile-for-build guile) store))))
1159 (define* (package-file package
1162 system (output "out") target)
1163 "Return as a monadic value the absolute file name of FILE within the
1164 OUTPUT directory of PACKAGE. When FILE is omitted, return the name of the
1165 OUTPUT directory of PACKAGE. When TARGET is true, use it as a
1166 cross-compilation target triplet."
1168 (define compute-derivation
1170 (cut package-cross-derivation <> <> target <>)
1171 package-derivation))
1173 (let* ((system (or system (%current-system)))
1174 (drv (compute-derivation store package system))
1175 (out (derivation->output-path drv output)))
1177 (string-append out "/" file)
1181 (define package->derivation
1182 (store-lift package-derivation))
1184 (define package->cross-derivation
1185 (store-lift package-cross-derivation))
1187 (define-gexp-compiler (package-compiler (package <package>) system target)
1188 ;; Compile PACKAGE to a derivation for SYSTEM, optionally cross-compiled for
1189 ;; TARGET. This is used when referring to a package from within a gexp.
1191 (package->cross-derivation package target system)
1192 (package->derivation package system)))
1194 (define* (origin->derivation origin
1195 #:optional (system (%current-system)))
1196 "Return the derivation corresponding to ORIGIN."
1198 (($ <origin> uri method sha256 name (= force ()) #f)
1199 ;; No patches, no snippet: this is a fixed-output derivation.
1200 (method uri 'sha256 sha256 name #:system system))
1201 (($ <origin> uri method sha256 name (= force (patches ...)) snippet
1202 (flags ...) inputs (modules ...) guile-for-build)
1203 ;; Patches and/or a snippet.
1204 (mlet %store-monad ((source (method uri 'sha256 sha256 name
1206 (guile (package->derivation (or guile-for-build
1210 (patch-and-repack source patches
1216 #:guile-for-build guile)))))
1218 (define-gexp-compiler (origin-compiler (origin <origin>) system target)
1219 ;; Compile ORIGIN to a derivation for SYSTEM. This is used when referring
1220 ;; to an origin from within a gexp.
1221 (origin->derivation origin system))
1223 (define package-source-derivation ;somewhat deprecated
1224 (let ((lower (store-lower lower-object)))
1225 (lambda* (store source #:optional (system (%current-system)))
1226 "Return the derivation or file corresponding to SOURCE, which can be an
1227 a file name or any object handled by 'lower-object', such as an <origin>.
1228 When SOURCE is a file name, return either the interned file name (if SOURCE is
1229 outside of the store) or SOURCE itself (if SOURCE is already a store item.)"
1231 ((and (? string?) (? direct-store-path?) file)
1234 (add-to-store store (basename file) #t "sha256" file))
1236 (lower store source system))))))