1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2014, 2015, 2017, 2018, 2019 Mark H Weaver <mhw@netris.org>
4 ;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
5 ;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
6 ;;; Copyright © 2017, 2019, 2020, 2022 Efraim Flashner <efraim@flashner.co.il>
7 ;;; Copyright © 2019 Marius Bakke <mbakke@fastmail.com>
8 ;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
9 ;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com>
10 ;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
12 ;;; This file is part of GNU Guix.
14 ;;; GNU Guix is free software; you can redistribute it and/or modify it
15 ;;; under the terms of the GNU General Public License as published by
16 ;;; the Free Software Foundation; either version 3 of the License, or (at
17 ;;; your option) any later version.
19 ;;; GNU Guix is distributed in the hope that it will be useful, but
20 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
21 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 ;;; GNU General Public License for more details.
24 ;;; You should have received a copy of the GNU General Public License
25 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
27 (define-module (guix packages)
28 #:use-module ((guix build utils) #:select (compressor tarball?
29 strip-store-file-name))
30 #:use-module (guix utils)
31 #:use-module (guix records)
32 #:use-module (guix store)
33 #:use-module (guix monads)
34 #:use-module (guix gexp)
35 #:use-module (guix base32)
36 #:autoload (guix base64) (base64-decode)
37 #:use-module (guix grafts)
38 #:use-module (guix derivations)
39 #:use-module (guix memoization)
40 #:use-module (guix build-system)
41 #:use-module (guix search-paths)
42 #:use-module (guix sets)
43 #:use-module (guix deprecation)
44 #:use-module (guix i18n)
45 #:use-module (ice-9 match)
46 #:use-module (ice-9 vlist)
47 #:use-module (ice-9 regex)
48 #:use-module (srfi srfi-1)
49 #:use-module (srfi srfi-9 gnu)
50 #:use-module (srfi srfi-11)
51 #:use-module (srfi srfi-26)
52 #:use-module (srfi srfi-34)
53 #:use-module (srfi srfi-35)
54 #:use-module (rnrs bytevectors)
55 #:use-module (web uri)
56 #:autoload (texinfo) (texi-fragment->stexi)
57 #:re-export (%current-system
58 %current-target-system
59 search-path-specification) ;for convenience
60 #:replace ((define-public* . define-public))
61 #:export (content-hash
63 content-hash-algorithm
72 origin-sha256 ;deprecated
74 origin-actual-file-name
96 package-propagated-inputs
98 package-native-search-paths
105 package-supported-systems
108 package-definition-location
113 package-field-location
116 this-package-native-input
119 lookup-package-native-input
120 lookup-package-propagated-input
121 lookup-package-direct-input
123 prepend ;syntactic keyword
124 replace ;syntactic keyword
127 package-direct-sources
128 package-transitive-sources
129 package-direct-inputs
130 package-transitive-inputs
131 package-transitive-target-inputs
132 package-transitive-native-inputs
133 package-transitive-propagated-inputs
134 package-transitive-native-search-paths
135 package-transitive-supported-systems
137 package-input-rewriting
138 package-input-rewriting/spec
139 package-source-derivation
141 package-cross-derivation
144 package-patched-vulnerabilities
146 package-with-extra-patches
147 package-with-c-toolchain
150 transitive-input-references
152 %32bit-supported-systems
153 %64bit-supported-systems
156 %cuirass-supported-systems
161 package-error-package
164 package-error-invalid-input
165 &package-cross-build-system-error
166 package-cross-build-system-error?
171 bag-transitive-inputs
172 bag-transitive-host-inputs
173 bag-transitive-build-inputs
174 bag-transitive-target-inputs
175 package-development-inputs
179 default-guile-derivation
183 package->cross-derivation
186 ;; The 'source-module-closure' procedure ca. 1.2.0 did not recognize
187 ;; #:re-export-and-replace: <https://issues.guix.gnu.org/52694>.
188 ;; Work around it. The #:replace? argument is only supported by
189 ;; Guile 2.2.7 and later, work-around it if necessary to allow
190 ;; time-travel from 1.1.0, see <https://issues.guix.gnu.org/53765>.
191 (let ((major (string->number (major-version))))
194 (= (string->number (minor-version)) 2) ; there is no Guile 2.3.X
195 (>= (string->number (micro-version)) 7)))
196 (module-re-export! (current-module) '(delete) #:replace? #t)
197 (module-re-export! (current-module) '(delete))))
201 ;;; This module provides a high-level mechanism to define packages in a
202 ;;; Guix-based distribution.
206 (define-syntax-rule (define-compile-time-decoder name string->bytevector)
207 "Define NAME as a macro that runs STRING->BYTEVECTOR at macro expansion time
211 "Return the bytevector corresponding to the given textual
215 (string? (syntax->datum #'str))
216 ;; A literal string: do the conversion at expansion time.
217 (with-syntax ((bv (string->bytevector (syntax->datum #'str))))
220 #'(string->bytevector str))))))
222 (define-compile-time-decoder base32 nix-base32-string->bytevector)
223 (define-compile-time-decoder base64 base64-decode)
225 ;; Crytographic content hash.
226 (define-immutable-record-type <content-hash>
227 (%content-hash algorithm value)
229 (algorithm content-hash-algorithm) ;symbol
230 (value content-hash-value)) ;bytevector
232 (define-syntax-rule (define-content-hash-constructor name
233 (algorithm size) ...)
234 "Define NAME as a <content-hash> constructor that ensures that (1) its
235 second argument is among the listed ALGORITHM, and (2), when possible, that
236 its first argument has the right size for the chosen algorithm."
239 (syntax-case s (algorithm ...)
241 (let ((bv* (syntax->datum #'bv)))
242 (when (and (bytevector? bv*)
243 (not (= size (bytevector-length bv*))))
244 (syntax-violation 'content-hash "invalid content hash length" s))
245 #'(%content-hash 'algorithm bv)))
248 (define-content-hash-constructor build-content-hash
255 (define-syntax content-hash
257 "Return a content hash with the given parameters. The default hash
258 algorithm is sha256. If the first argument is a literal string, it is decoded
259 as base32. Otherwise, it must be a bytevector."
260 ;; What we'd really want here is something like C++ 'constexpr'.
263 (string? (syntax->datum #'str))
264 #'(content-hash str sha256))
266 (string? (syntax->datum #'str))
267 (with-syntax ((bv (base32 (syntax->datum #'str))))
268 #'(content-hash bv algorithm)))
269 ((_ (id str) algorithm)
270 (and (string? (syntax->datum #'str))
271 (free-identifier=? #'id #'base32))
272 (with-syntax ((bv (nix-base32-string->bytevector (syntax->datum #'str))))
273 #'(content-hash bv algorithm)))
274 ((_ (id str) algorithm)
275 (and (string? (syntax->datum #'str))
276 (free-identifier=? #'id #'base64))
277 (with-syntax ((bv (base64-decode (syntax->datum #'str))))
278 #'(content-hash bv algorithm)))
280 #'(content-hash bv sha256))
282 #'(build-content-hash bv hash)))))
284 (define (print-content-hash hash port)
285 (format port "#<content-hash ~a:~a>"
286 (content-hash-algorithm hash)
287 (and=> (content-hash-value hash)
288 bytevector->nix-base32-string)))
290 (set-record-type-printer! <content-hash> print-content-hash)
293 ;; The source of a package, such as a tarball URL and fetcher---called
294 ;; "origin" to avoid name clash with `package-source', `source', etc.
295 (define-record-type* <origin>
299 (uri origin-uri) ; string
300 (method origin-method) ; procedure
301 (hash origin-hash) ; <content-hash>
302 (file-name origin-file-name (default #f)) ; optional file name
304 ;; Patches are delayed so that the 'search-patch' calls are made lazily,
305 ;; which reduces I/O on startup and allows patch-not-found errors to be
306 ;; gracefully handled at run time.
307 (patches origin-patches ; list of file names
308 (default '()) (delayed))
310 (snippet origin-snippet (default #f)) ; sexp or #f
311 (patch-flags origin-patch-flags ; string-list gexp
312 (default %default-patch-flags))
314 ;; Patching requires Guile, GNU Patch, and a few more. These two fields are
315 ;; used to specify these dependencies when needed.
316 (patch-inputs origin-patch-inputs ; input list or #f
318 (modules origin-modules ; list of module names
321 (patch-guile origin-patch-guile ; package or #f
324 (define-syntax origin-compatibility-helper
325 (syntax-rules (sha256)
327 (%origin fields ...))
328 ((_ ((sha256 exp) rest ...) (others ...))
330 (hash (content-hash exp sha256))
332 ((_ (field rest ...) (others ...))
333 (origin-compatibility-helper (rest ...)
334 (others ... field)))))
336 (define-syntax-rule (origin fields ...)
337 "Build an <origin> record, automatically converting 'sha256' field
338 specifications to 'hash'."
339 (origin-compatibility-helper (fields ...) ()))
341 (define-deprecated (origin-sha256 origin)
343 (let ((hash (origin-hash origin)))
344 (unless (eq? (content-hash-algorithm hash) 'sha256)
345 (raise (condition (&message
346 (message (G_ "no SHA256 hash for origin"))))))
347 (content-hash-value hash)))
349 (define (print-origin origin port)
350 "Write a concise representation of ORIGIN to PORT."
352 (($ <origin> uri method hash file-name patches)
353 (simple-format port "#<origin ~s ~a ~s ~a>"
356 (number->string (object-address origin) 16)))))
358 (set-record-type-printer! <origin> print-origin)
360 (define %default-patch-flags
363 (define (origin-actual-file-name origin)
364 "Return the file name of ORIGIN, either its 'file-name' field or the file
366 (define (uri->file-name uri)
367 ;; Return the 'base name' of URI or URI itself, where URI is a string.
368 (let ((path (and=> (string->uri uri) uri-path)))
373 (or (origin-file-name origin)
374 (match (origin-uri origin)
376 (uri->file-name head))
378 (uri->file-name uri))
380 ;; git, svn, cvs, etc. reference
383 ;; Work around limitations in the 'snippet' mechanism. It is not possible for
384 ;; a 'snippet' to produce a tarball with a different base name than the
385 ;; original downloaded source. Moreover, cherry picking dozens of upsteam
386 ;; patches and applying them suddenly is often impractical; especially when a
387 ;; comprehensive code reformatting is done upstream. Mainly designed for
388 ;; Linux and IceCat packages.
389 ;; XXXX: do not make part of public API (export) such radical capability
390 ;; before a detailed review process.
391 (define* (computed-origin-method gexp-promise hash-algo hash
392 #:optional (name "source")
393 #:key (system (%current-system))
394 (guile (default-guile)))
395 "Return a derivation that executes the G-expression that results
396 from forcing GEXP-PROMISE."
397 (mlet %store-monad ((guile (package->derivation guile system)))
398 (gexp->derivation (or name "computed-origin")
400 #:graft? #f ;nothing to graft
402 #:guile-for-build guile)))
405 (define %32bit-supported-systems
406 ;; This is the list of 32-bit system types that are supported.
407 '("i686-linux" "armhf-linux" "i586-gnu" "powerpc-linux"))
409 (define %64bit-supported-systems
410 ;; This is the list of 64-bit system types that are supported.
411 '("x86_64-linux" "mips64el-linux" "aarch64-linux" "powerpc64le-linux"
414 (define %supported-systems
415 ;; This is the list of system types that are supported. By default, we
416 ;; expect all packages to build successfully here.
417 (append %64bit-supported-systems %32bit-supported-systems))
419 (define %hurd-systems
420 ;; The GNU/Hurd systems for which support is being developed.
421 '("i586-gnu" "i686-gnu"))
423 (define %cuirass-supported-systems
424 ;; This is the list of system types for which build machines are available.
426 ;; XXX: MIPS is unavailable in CI:
427 ;; <https://lists.gnu.org/archive/html/guix-devel/2017-03/msg00790.html>.
428 (fold delete %supported-systems '("mips64el-linux" "powerpc-linux" "riscv64-linux")))
430 (define-inlinable (sanitize-inputs inputs)
431 "Sanitize INPUTS by turning it into a list of name/package tuples if it's
432 not already the case."
433 (cond ((null? inputs) inputs)
434 ((and (pair? (car inputs))
435 (string? (caar inputs)))
437 (else (map add-input-label inputs))))
439 (define-syntax current-location-vector
441 "Like 'current-source-location' but expand to a literal vector with
442 one-indexed line numbers."
443 ;; Storing a literal vector in .go files is more efficient than storing an
444 ;; alist: less initialization code, fewer relocations, etc.
447 (match (syntax-source s)
450 (let ((file (assq-ref properties 'filename))
451 (line (assq-ref properties 'line))
452 (column (assq-ref properties 'column)))
453 (and file line column
454 #`#(#,file #,(+ 1 line) #,column)))))))))
456 (define-inlinable (sanitize-location loc)
457 ;; Convert LOC to a vector or to #f.
458 (cond ((vector? loc) loc)
460 (else (vector (location-file loc)
462 (location-column loc)))))
464 (define-syntax-parameter current-definition-location
465 ;; Location of the encompassing 'define-public'.
468 (define-syntax define-public*
470 "Like 'define-public' but set 'current-definition-location' for the
471 lexical scope of its body."
473 (match (syntax-source s)
476 (let ((line (assq-ref properties 'line))
477 (column (assq-ref properties 'column)))
478 ;; Don't repeat the file name since it's redundant with 'location'.
479 ;; Encode the whole thing so that it fits in a fixnum on 32-bit
480 ;; platforms, which leaves us 29 bits: 7 bits for COLUMN (which is
481 ;; almost always zero), and 22 bits for LINE.
483 (logior (ash (logand #x7f column) 22)
484 (logand (- (expt 2 22) 1) (+ 1 line))))))))
487 ((_ prototype body ...)
488 #`(define-public prototype
489 (syntax-parameterize ((current-definition-location
490 (lambda (s) #,location)))
493 (define-syntax validate-texinfo
494 (let ((validate? (getenv "GUIX_UNINSTALLED")))
495 (define ensure-thread-safe-texinfo-parser!
496 ;; Work around <https://issues.guix.gnu.org/51264> for Guile <= 3.0.7.
497 (let ((patched? (or (> (string->number (major-version)) 3)
498 (> (string->number (minor-version)) 0)
499 (> (string->number (micro-version)) 7)))
500 (next-token-of/thread-safe
502 (let loop ((chars '()))
503 (match (read-char port)
505 (list->string (reverse! chars)))
507 (let ((chr* (pred chr)))
509 (loop (cons chr* chars))
511 (unread-char chr port)
512 (list->string (reverse! chars)))))))))))
515 (set! (@@ (texinfo) next-token-of) next-token-of/thread-safe)
516 (set! patched? #t)))))
519 "Raise a syntax error when passed a literal string that is not valid
520 Texinfo. Otherwise, return the string."
523 (string? (syntax->datum #'str))
527 (ensure-thread-safe-texinfo-parser!)
528 (texi-fragment->stexi (syntax->datum #'str))
531 (syntax-violation 'package "invalid Texinfo markup" #'str)))
537 (define-record-type* <package>
541 (name package-name) ; string
542 (version package-version) ; string
543 (source package-source) ; <origin> instance
544 (build-system package-build-system) ; <build-system> instance
545 (arguments package-arguments ; arguments for the build method
546 (default '()) (thunked))
548 (inputs package-inputs ; input packages or derivations
549 (default '()) (thunked)
550 (sanitize sanitize-inputs))
551 (propagated-inputs package-propagated-inputs ; same, but propagated
552 (default '()) (thunked)
553 (sanitize sanitize-inputs))
554 (native-inputs package-native-inputs ; native input packages/derivations
555 (default '()) (thunked)
556 (sanitize sanitize-inputs))
558 (outputs package-outputs ; list of strings
562 ; <search-path-specification>,
563 ; for native and cross
565 (native-search-paths package-native-search-paths (default '()))
566 (search-paths package-search-paths (default '()))
568 ;; The 'replacement' field is marked as "innate" because it never makes
569 ;; sense to inherit a replacement as is. See the 'package/inherit' macro.
570 (replacement package-replacement ; package | #f
571 (default #f) (thunked) (innate))
573 (synopsis package-synopsis
574 (sanitize validate-texinfo)) ; one-line description
575 (description package-description
576 (sanitize validate-texinfo)) ; one or two paragraphs
577 (license package-license) ; (list of) <license>
578 (home-page package-home-page)
579 (supported-systems package-supported-systems ; list of strings
580 (default %supported-systems))
582 (properties package-properties (default '())) ; alist for anything else
584 (location package-location-vector
585 (default (current-location-vector))
586 (innate) (sanitize sanitize-location))
587 (definition-location package-definition-location-code
588 (default (current-definition-location))
591 (define (add-input-label input)
592 "Add an input label to INPUT."
594 ((? package? package)
595 (list (package-name package) package))
596 (((? package? package) output) ;XXX: ugly?
597 (list (package-name package) package output))
598 ((? gexp-input?) ;XXX: misplaced because 'native?' field is ignored?
599 (let ((obj (gexp-input-thing input))
600 (output (gexp-input-output input)))
601 `(,(if (package? obj)
605 ,@(if (string=? output "out") '() (list output)))))
609 (set-record-type-printer! <package>
610 (lambda (package port)
611 (let ((loc (package-location package))
612 (format simple-format))
613 (format port "#<package ~a@~a ~a~a>"
614 (package-name package)
615 (package-version package)
621 (number->string (object-address
625 (define (package-location package)
626 "Return the source code location of PACKAGE as a <location> record, or #f if
628 (match (package-location-vector package)
630 (#(file line column) (location file line column))))
632 (define (package-definition-location package)
633 "Like 'package-location', but return the location of the definition
634 itself--i.e., that of the enclosing 'define-public' form, if any, or #f."
635 (match (package-definition-location-code package)
638 (let ((column (bit-extract code 22 29))
639 (line (bit-extract code 0 21)))
640 (match (package-location-vector package)
642 (#(file _ _) (location file line column)))))))
644 (define-syntax-rule (package/inherit p overrides ...)
645 "Like (package (inherit P) OVERRIDES ...), except that the same
646 transformation is done to the package P's replacement, if any. P must be a bare
647 identifier, and will be bound to either P or its replacement when evaluating
652 (replacement (and=> (package-replacement p) loop)))))
654 (define (package-upstream-name package)
655 "Return the upstream name of PACKAGE, which could be different from the name
657 (or (assq-ref (package-properties package) 'upstream-name)
658 (package-name package)))
660 (define (hidden-package p)
661 "Return a \"hidden\" version of P--i.e., one that 'fold-packages' and thus,
662 user interfaces, ignores."
665 (location (package-location p))
666 (properties `((hidden? . #t)
667 ,@(package-properties p)))))
669 (define (hidden-package? p)
670 "Return true if P is \"hidden\"--i.e., must not be visible to user
672 (assoc-ref (package-properties p) 'hidden?))
674 (define (package-superseded p)
675 "Return the package that supersedes P, or #f if P is still current."
676 (assoc-ref (package-properties p) 'superseded))
678 (define (deprecated-package old-name p)
679 "Return a package called OLD-NAME and marked as superseded by P, a package
684 (properties `((superseded . ,p)))))
686 (define (package-field-location package field)
687 "Return the source code location of the definition of FIELD for PACKAGE, or
688 #f if it could not be determined."
689 (match (package-location package)
690 (($ <location> file line column)
691 (match (search-path %load-path file)
692 ((? string? file-found)
695 ;; In general we want to keep relative file names for modules.
696 (call-with-input-file file-found
698 (go-to-location port line column)
700 (('package inits ...)
701 (let ((field (assoc field inits)))
704 (let ((loc (and=> (source-properties value)
705 source-properties->location)))
707 ;; Preserve the original file name, which may be a
708 ;; relative file name.
709 (set-field loc (location-file) file))))
717 ;; FILE could not be found in %LOAD-PATH.
721 (define-syntax-rule (this-package-input name)
722 "Return the input NAME of the package being defined--i.e., an input
723 from the ‘inputs’ or ‘propagated-inputs’ field. Native inputs are not
724 considered. If this input does not exist, return #f instead."
725 (or (lookup-package-input this-package name)
726 (lookup-package-propagated-input this-package name)))
728 (define-syntax-rule (this-package-native-input name)
729 "Return the native package input NAME of the package being defined--i.e.,
730 an input from the ‘native-inputs’ field. If this native input does not
731 exist, return #f instead."
732 (lookup-package-native-input this-package name))
736 (define-condition-type &package-error &error
738 (package package-error-package))
740 (define-condition-type &package-input-error &package-error
742 (input package-error-invalid-input))
744 (define-condition-type &package-cross-build-system-error &package-error
745 package-cross-build-system-error?)
747 (define* (package-full-name package #:optional (delimiter "@"))
748 "Return the full name of PACKAGE--i.e., `NAME@VERSION'. By specifying
749 DELIMITER (a string), you can customize what will appear between the name and
750 the version. By default, DELIMITER is \"@\"."
751 (string-append (package-name package) delimiter (package-version package)))
753 (define (patch-file-name patch)
754 "Return the basename of PATCH's file name, or #f if the file name could not
760 (and=> (origin-actual-file-name patch) basename))))
762 (define %vulnerability-regexp
763 ;; Regexp matching a CVE identifier in patch file names.
764 (make-regexp "CVE-[0-9]{4}-[0-9]+"))
766 (define (package-patched-vulnerabilities package)
767 "Return the list of patched vulnerabilities of PACKAGE as a list of CVE
768 identifiers. The result is inferred from the file names of patches."
769 (define (patch-vulnerabilities patch)
770 (map (cut match:substring <> 0)
771 (list-matches %vulnerability-regexp patch)))
773 (let ((patches (filter-map patch-file-name
774 (or (and=> (package-source package)
777 (append-map patch-vulnerabilities patches)))
779 (define (%standard-patch-inputs)
780 (let* ((canonical (module-ref (resolve-interface '(gnu packages base))
782 (ref (lambda (module var)
783 ;; Make sure 'canonical-package' is not influenced by
784 ;; '%current-target-system' since we're going to use the
785 ;; native package anyway.
786 (parameterize ((%current-target-system #f))
788 (module-ref (resolve-interface module) var))))))
789 `(("tar" ,(ref '(gnu packages base) 'tar))
790 ("xz" ,(ref '(gnu packages compression) 'xz))
791 ("bzip2" ,(ref '(gnu packages compression) 'bzip2))
792 ("gzip" ,(ref '(gnu packages compression) 'gzip))
793 ("lzip" ,(ref '(gnu packages compression) 'lzip))
794 ("unzip" ,(ref '(gnu packages compression) 'unzip))
795 ("patch" ,(ref '(gnu packages base) 'patch))
796 ("locales" ,(ref '(gnu packages base) 'glibc-utf8-locales)))))
798 (define (default-guile)
799 "Return the default Guile package used to run the build code of
801 (let ((distro (resolve-interface '(gnu packages commencement))))
802 (module-ref distro 'guile-final)))
804 (define (guile-for-grafts)
805 "Return the Guile package used to build grafting derivations."
806 ;; Guile 2.2 would not work due to <https://bugs.gnu.org/28211> when
807 ;; grafting packages.
808 (let ((distro (resolve-interface '(gnu packages guile))))
809 (module-ref distro 'guile-2.0)))
811 (define* (default-guile-derivation #:optional (system (%current-system)))
812 "Return the derivation for SYSTEM of the default Guile package used to run
813 the build code of derivation."
814 (package->derivation (default-guile) system
817 (define* (patch-and-repack source patches
821 (flags %default-patch-flags)
823 (guile-for-build (%guile-for-build))
824 (system (%current-system)))
825 "Unpack SOURCE (a derivation or store path), apply all of PATCHES, and
826 repack the tarball using the tools listed in INPUTS. When SNIPPET is true,
827 it must be an s-expression that will run from within the directory where
828 SOURCE was unpacked, after all of PATCHES have been applied. MODULES
829 specifies modules in scope when evaluating SNIPPET."
830 (define source-file-name
831 ;; SOURCE is usually a derivation, but it could be a store file.
832 (if (derivation? source)
833 (derivation->output-path source)
837 ;; The default value of the 'patch-inputs' field, and thus INPUTS is #f,
838 ;; so deal with that.
839 (let ((inputs (or inputs (%standard-patch-inputs))))
841 (match (assoc-ref inputs name)
845 (define original-file-name (strip-store-file-name source-file-name))
847 (define (numeric-extension? file-name)
848 ;; Return true if FILE-NAME ends with digits.
849 (and=> (file-extension file-name)
850 (cut string-every char-set:hex-digit <>)))
852 (define (checkout? directory)
853 ;; Return true if DIRECTORY is a checkout (git, svn, etc).
854 (string-suffix? "-checkout" directory))
856 (define (tarxz-name file-name)
857 ;; Return a '.tar.xz' file name based on FILE-NAME.
858 (let ((base (if (numeric-extension? file-name)
860 (file-sans-extension file-name))))
862 (if (equal? (file-extension base) "tar")
866 (define instantiate-patch
868 ((? string? patch) ;deprecated
869 (local-file patch #:recursive? #t))
870 ((? struct? patch) ;origin, local-file, etc.
873 (let ((tar (lookup-input "tar"))
874 (gzip (lookup-input "gzip"))
875 (bzip2 (lookup-input "bzip2"))
876 (lzip (lookup-input "lzip"))
877 (xz (lookup-input "xz"))
878 (patch (lookup-input "patch"))
879 (locales (lookup-input "locales"))
880 (comp (and=> (compressor source-file-name) lookup-input))
881 (patches (map instantiate-patch patches)))
883 (with-imported-modules '((guix build utils))
885 (use-modules (ice-9 ftw)
892 ;; The --sort option was added to GNU tar in version 1.28, released
893 ;; 2014-07-28. During bootstrap we must cope with older versions.
894 (define tar-supports-sort?
895 (zero? (system* (string-append #+tar "/bin/tar")
896 "cf" "/dev/null" "--files-from=/dev/null"
899 (define (apply-patch patch)
900 (format (current-error-port) "applying '~a'...~%" patch)
902 ;; Use '--force' so that patches that do not apply perfectly are
903 ;; rejected. Use '--no-backup-if-mismatch' to prevent making
904 ;; "*.orig" file if a patch is applied with offset.
905 (invoke (string-append #+patch "/bin/patch")
906 "--force" "--no-backup-if-mismatch"
907 #+@flags "--input" patch))
909 (define (first-file directory)
910 ;; Return the name of the first file in DIRECTORY.
911 (car (scandir directory
913 (not (member name '("." "..")))))))
915 (define (repack directory output)
916 ;; Write to OUTPUT a compressed tarball containing DIRECTORY.
917 (unless tar-supports-sort?
918 (call-with-output-file ".file_list"
920 (for-each (lambda (name)
921 (format port "~a~%" name))
922 (find-files directory
924 #:fail-on-error? #t)))))
926 (apply invoke #+(file-append tar "/bin/tar")
928 ;; Avoid non-determinism in the archive. Set the mtime
929 ;; to 1 as is the case in the store (software like gzip
930 ;; behaves differently when it stumbles upon mtime = 0).
932 "--owner=root:0" "--group=root:0"
933 (if tar-supports-sort?
934 `("--sort=name" ,directory)
936 "--files-from=.file_list"))))
938 ;; Encoding/decoding errors shouldn't be silent.
939 (fluid-set! %default-port-conversion-strategy 'error)
942 ;; First of all, install a UTF-8 locale so that UTF-8 file names
943 ;; are correctly interpreted. During bootstrap, LOCALES is #f.
945 (string-append #+locales "/lib/locale/"
948 (package-version locales)))))
949 (setlocale LC_ALL "en_US.utf8"))
952 (string-append #+xz "/bin"
954 (string-append ":" #+comp "/bin")
957 (setenv "XZ_DEFAULTS" (string-join (%xz-parallel-args)))
959 ;; SOURCE may be either a directory, a tarball or a simple file.
960 (let ((name (strip-store-file-name #+source))
961 (command (and=> #+comp (cut string-append <> "/bin/"
962 (compressor #+source)))))
963 (if (file-is-directory? #+source)
964 (copy-recursively #+source name)
967 (invoke (string-append #+tar "/bin/tar") "xvf" #+source))
968 ((and=> (compressor #+source) (cut string= "unzip" <>))
969 ;; Note: Referring to the store unzip here (#+unzip)
970 ;; would introduce a cycle.
971 (invoke "unzip" #+source))
973 (copy-file #+source name)
975 (invoke command "--decompress" name))))))
977 (let* ((file (first-file "."))
978 (directory (if (file-is-directory? file)
981 (format (current-error-port) "source is at '~a'~%" file)
983 (with-directory-excursion directory
985 (for-each apply-patch '#+patches)
988 #~(let ((module (make-fresh-user-module)))
989 (module-use-interfaces!
991 (map resolve-interface '#+modules))
992 ((@ (system base compile) compile)
993 '#+(if (pair? snippet)
997 #:opts %auto-compilation-options
1001 ;; If SOURCE is a directory (such as a checkout), return a
1002 ;; directory. Otherwise create a tarball.
1004 ((file-is-directory? #+source)
1005 (copy-recursively directory #$output
1006 #:log (%make-void-port "w")))
1007 ((or #+comp (tarball? #+source))
1008 (repack directory #$output))
1009 (else ;single uncompressed file
1010 (copy-file file #$output)))))))
1012 (let ((name (if (or (checkout? original-file-name)
1013 (not (compressor original-file-name)))
1015 (tarxz-name original-file-name))))
1016 (gexp->derivation name build
1019 #:guile-for-build guile-for-build
1020 #:properties `((type . origin)
1021 (patches . ,(length patches)))))))
1023 (define (package-with-patches original patches)
1024 "Return package ORIGINAL with PATCHES applied."
1025 (package (inherit original)
1026 (source (origin (inherit (package-source original))
1028 (location (package-location original))))
1030 (define (package-with-extra-patches original patches)
1031 "Return package ORIGINAL with all PATCHES appended to its list of patches."
1032 (package-with-patches original
1033 (append (origin-patches (package-source original))
1036 (define (package-with-c-toolchain package toolchain)
1037 "Return a variant of PACKAGE that uses TOOLCHAIN instead of the default GNU
1038 C/C++ toolchain. TOOLCHAIN must be a list of inputs (label/package tuples)
1039 providing equivalent functionality, such as the 'gcc-toolchain' package."
1040 (let ((bs (package-build-system package)))
1041 (package/inherit package
1042 (build-system (build-system-with-c-toolchain bs toolchain)))))
1044 (define (transitive-inputs inputs)
1045 "Return the closure of INPUTS when considering the 'propagated-inputs'
1046 edges. Omit duplicate inputs, except for those already present in INPUTS
1049 This is implemented as a breadth-first traversal such that INPUTS is
1050 preserved, and only duplicate propagated inputs are removed."
1051 (define (seen? seen item outputs)
1052 ;; FIXME: We're using pointer identity here, which is extremely sensitive
1053 ;; to memoization in package-producing procedures; see
1054 ;; <https://bugs.gnu.org/30155>.
1055 (match (vhash-assq item seen)
1056 ((_ . o) (equal? o outputs))
1059 (let loop ((inputs inputs)
1066 (if (null? propagated)
1068 (loop (reverse (concatenate propagated)) result '() #f seen)))
1069 (((and input (label (? package? package) outputs ...)) rest ...)
1070 (if (and (not first?) (seen? seen package outputs))
1071 (loop rest result propagated first? seen)
1074 (cons (package-propagated-inputs package) propagated)
1076 (vhash-consq package outputs seen))))
1078 (loop rest (cons input result) propagated first? seen)))))
1080 (define (lookup-input inputs name)
1081 "Lookup NAME among INPUTS, an input list."
1082 ;; Note: Currently INPUTS is assumed to be an input list that contains input
1083 ;; labels. In the future, input labels will be gone and this procedure will
1084 ;; check package names.
1085 (match (assoc-ref inputs name)
1090 (define (lookup-package-input package name)
1091 "Look up NAME among PACKAGE's inputs. Return it if found, #f otherwise."
1092 (lookup-input (package-inputs package) name))
1094 (define (lookup-package-native-input package name)
1095 "Look up NAME among PACKAGE's native inputs. Return it if found, #f
1097 (lookup-input (package-native-inputs package) name))
1099 (define (lookup-package-propagated-input package name)
1100 "Look up NAME among PACKAGE's propagated inputs. Return it if found, #f
1102 (lookup-input (package-propagated-inputs package) name))
1104 (define (lookup-package-direct-input package name)
1105 "Look up NAME among PACKAGE's direct inputs. Return it if found, #f
1107 (lookup-input (package-direct-inputs package) name))
1109 (define (replace-input name replacement inputs)
1110 "Replace input NAME by REPLACEMENT within INPUTS."
1111 (map (lambda (input)
1113 (((? string? label) _ . outputs)
1114 (if (string=? label name)
1115 (match replacement ;does REPLACEMENT specify an output?
1116 ((_ _) (cons label replacement))
1117 (_ (cons* label replacement outputs)))
1121 (define-syntax prepend
1123 (syntax-violation 'prepend
1124 "'prepend' may only be used within 'modify-inputs'"
1127 (define-syntax replace
1129 (syntax-violation 'replace
1130 "'replace' may only be used within 'modify-inputs'"
1133 (define-syntax modify-inputs
1134 (syntax-rules (delete prepend append replace)
1135 "Modify the given package inputs, as returned by 'package-inputs' & co.,
1136 according to the given clauses. The example below removes the GMP and ACL
1137 inputs of Coreutils and adds libcap:
1139 (modify-inputs (package-inputs coreutils)
1140 (delete \"gmp\" \"acl\")
1143 Other types of clauses include 'prepend' and 'replace'.
1145 The first argument must be a labeled input list; the result is also a labeled
1147 ;; Note: This macro hides the fact that INPUTS, as returned by
1148 ;; 'package-inputs' & co., is actually an alist with labels. Eventually,
1149 ;; it will operate on list of inputs without labels.
1150 ((_ inputs (delete name) clauses ...)
1151 (modify-inputs (alist-delete name inputs)
1153 ((_ inputs (delete names ...) clauses ...)
1154 (modify-inputs (fold alist-delete inputs (list names ...))
1156 ((_ inputs (prepend lst ...) clauses ...)
1157 (modify-inputs (append (map add-input-label (list lst ...)) inputs)
1159 ((_ inputs (append lst ...) clauses ...)
1160 (modify-inputs (append inputs (map add-input-label (list lst ...)))
1162 ((_ inputs (replace name replacement) clauses ...)
1163 (modify-inputs (replace-input name replacement inputs)
1168 (define (package-direct-sources package)
1169 "Return all source origins associated with PACKAGE; including origins in
1171 `(,@(or (and=> (package-source package) list) '())
1172 ,@(filter-map (match-lambda
1173 ((_ (? origin? orig) _ ...)
1176 (package-direct-inputs package))))
1178 (define (package-transitive-sources package)
1179 "Return PACKAGE's direct sources, and their direct sources, recursively."
1181 (concatenate (filter-map (match-lambda
1182 ((_ (? origin? orig) _ ...)
1184 ((_ (? package? p) _ ...)
1185 (package-direct-sources p))
1187 (bag-transitive-inputs
1188 (package->bag package))))))
1190 (define (package-direct-inputs package)
1191 "Return all the direct inputs of PACKAGE---i.e, its direct inputs along
1192 with their propagated inputs."
1193 (append (package-native-inputs package)
1194 (package-inputs package)
1195 (package-propagated-inputs package)))
1197 (define (package-transitive-inputs package)
1198 "Return the transitive inputs of PACKAGE---i.e., its direct inputs along
1199 with their propagated inputs, recursively."
1200 (transitive-inputs (package-direct-inputs package)))
1202 (define (package-transitive-target-inputs package)
1203 "Return the transitive target inputs of PACKAGE---i.e., its direct inputs
1204 along with their propagated inputs, recursively. This only includes inputs
1205 for the target system, and not native inputs."
1206 (transitive-inputs (append (package-inputs package)
1207 (package-propagated-inputs package))))
1209 (define (package-transitive-native-inputs package)
1210 "Return the transitive native inputs of PACKAGE---i.e., its direct inputs
1211 along with their propagated inputs, recursively. This only includes inputs
1212 for the host system (\"native inputs\"), and not target inputs."
1213 (transitive-inputs (package-native-inputs package)))
1215 (define (package-transitive-propagated-inputs package)
1216 "Return the propagated inputs of PACKAGE, and their propagated inputs,
1218 (transitive-inputs (package-propagated-inputs package)))
1220 (define (package-transitive-native-search-paths package)
1221 "Return the list of search paths for PACKAGE and its propagated inputs,
1223 (append (package-native-search-paths package)
1224 (append-map (match-lambda
1225 ((label (? package? p) _ ...)
1226 (package-native-search-paths p))
1229 (package-transitive-propagated-inputs package))))
1231 (define (transitive-input-references alist inputs)
1232 "Return a list of (assoc-ref ALIST <label>) for each (<label> <package> . _)
1233 in INPUTS and their transitive propagated inputs."
1239 (map (lambda (input)
1240 `(assoc-ref ,alist ,(label input)))
1241 (transitive-inputs inputs)))
1243 (define package-transitive-supported-systems
1245 (define (supported-systems-procedure system)
1246 (define supported-systems
1248 (parameterize ((%current-system system))
1249 (fold (lambda (input systems)
1251 ((label (? package? package) . _)
1252 (lset-intersection string=? systems
1253 (supported-systems package)))
1256 (package-supported-systems package)
1257 (bag-direct-inputs (package->bag package system #f))))))
1262 ;; Map system strings to one-argument procedures. This allows these
1263 ;; procedures to have fast 'eq?' memoization on their argument.
1266 (lambda* (package #:optional (system (%current-system)))
1267 "Return the intersection of the systems supported by PACKAGE and those
1268 supported by its dependencies."
1269 (match (hash-ref procs system)
1271 (hash-set! procs system (supported-systems-procedure system))
1272 (package-transitive-supported-systems package system))
1276 (define* (supported-package? package #:optional (system (%current-system)))
1277 "Return true if PACKAGE is supported on SYSTEM--i.e., if PACKAGE and all its
1278 dependencies are known to build on SYSTEM."
1279 (member system (package-transitive-supported-systems package system)))
1281 (define (bag-direct-inputs bag)
1282 "Same as 'package-direct-inputs', but applied to a bag."
1283 (append (bag-build-inputs bag)
1284 (bag-host-inputs bag)
1285 (bag-target-inputs bag)))
1287 (define (bag-transitive-inputs bag)
1288 "Same as 'package-transitive-inputs', but applied to a bag."
1289 (parameterize ((%current-target-system #f)
1290 (%current-system (bag-system bag)))
1291 (transitive-inputs (bag-direct-inputs bag))))
1293 (define (bag-transitive-build-inputs bag)
1294 "Same as 'package-transitive-native-inputs', but applied to a bag."
1295 (parameterize ((%current-target-system #f)
1296 (%current-system (bag-system bag)))
1297 (transitive-inputs (bag-build-inputs bag))))
1299 (define (bag-transitive-host-inputs bag)
1300 "Same as 'package-transitive-target-inputs', but applied to a bag."
1301 (parameterize ((%current-target-system (bag-target bag))
1302 (%current-system (bag-system bag)))
1303 (transitive-inputs (bag-host-inputs bag))))
1305 (define (bag-transitive-target-inputs bag)
1306 "Return the \"target inputs\" of BAG, recursively."
1307 (parameterize ((%current-target-system (bag-target bag))
1308 (%current-system (bag-system bag)))
1309 (transitive-inputs (bag-target-inputs bag))))
1311 (define* (package-development-inputs package
1312 #:optional (system (%current-system))
1314 "Return the list of inputs required by PACKAGE for development purposes on
1315 SYSTEM. When TARGET is true, return the inputs needed to cross-compile
1316 PACKAGE from SYSTEM to TRIPLET, where TRIPLET is a triplet such as
1317 \"aarch64-linux-gnu\"."
1318 (bag-transitive-inputs (package->bag package system target)))
1320 (define* (package-closure packages #:key (system (%current-system)))
1321 "Return the closure of PACKAGES on SYSTEM--i.e., PACKAGES and the list of
1322 packages they depend on, recursively."
1323 (let loop ((packages packages)
1324 (visited vlist-null)
1325 (closure (list->setq packages)))
1328 (set->list closure))
1330 (if (vhash-assq package visited)
1331 (loop rest visited closure)
1332 (let* ((bag (package->bag package system))
1333 (dependencies (filter-map (match-lambda
1334 ((label (? package? package) . _)
1337 (bag-direct-inputs bag))))
1338 (loop (append dependencies rest)
1339 (vhash-consq package #t visited)
1340 (fold set-insert closure dependencies))))))))
1342 (define (build-system-with-package-mapping bs rewrite)
1343 "Return a variant of BS, a build system, that rewrites a bag's inputs by
1344 passing them through REWRITE, a procedure that takes an input tuplet and
1345 returns a \"rewritten\" input tuplet."
1347 (build-system-lower bs))
1349 (define (lower* . args)
1350 (let ((lowered (apply lower args)))
1353 (build-inputs (map rewrite (bag-build-inputs lowered)))
1354 (host-inputs (map rewrite (bag-host-inputs lowered)))
1355 (target-inputs (map rewrite (bag-target-inputs lowered))))))
1361 (define* (package-mapping proc #:optional (cut? (const #f))
1363 "Return a procedure that, given a package, applies PROC to all the packages
1364 depended on and returns the resulting package. The procedure stops recursion
1365 when CUT? returns true for a given package. When DEEP? is true, PROC is
1366 applied to implicit inputs as well."
1367 (define (rewrite input)
1369 ((label (? package? package) outputs ...)
1370 (cons* label (replace package) outputs))
1374 (define mapping-property
1375 ;; Property indicating whether the package has already been processed.
1376 (gensym " package-mapping-done"))
1380 ;; If P is the result of a previous call, return it.
1381 (cond ((assq-ref (package-properties p) mapping-property)
1385 ;; Since P's propagated inputs are really inputs of its dependents,
1386 ;; rewrite them as well, unless we're doing a "shallow" rewrite.
1389 (null? (package-propagated-inputs p)))
1393 (location (package-location p))
1394 (replacement (package-replacement p))
1395 (propagated-inputs (map rewrite (package-propagated-inputs p)))
1396 (properties `((,mapping-property . #t)
1397 ,@(package-properties p)))))))
1400 ;; Return a variant of P with PROC applied to P and its explicit
1401 ;; dependencies, recursively. Memoize the transformations. Failing
1402 ;; to do that, we would build a huge object graph with lots of
1403 ;; duplicates, which in turns prevents us from benefiting from
1404 ;; memoization in 'package-derivation'.
1408 (location (package-location p))
1409 (build-system (if deep?
1410 (build-system-with-package-mapping
1411 (package-build-system p) rewrite)
1412 (package-build-system p)))
1413 (inputs (map rewrite (package-inputs p)))
1414 (native-inputs (map rewrite (package-native-inputs p)))
1415 (propagated-inputs (map rewrite (package-propagated-inputs p)))
1416 (replacement (and=> (package-replacement p) replace))
1417 (properties `((,mapping-property . #t)
1418 ,@(package-properties p)))))))))
1422 (define* (package-input-rewriting replacements
1423 #:optional (rewrite-name identity)
1425 "Return a procedure that, when passed a package, replaces its direct and
1426 indirect dependencies, including implicit inputs when DEEP? is true, according
1427 to REPLACEMENTS. REPLACEMENTS is a list of package pairs; the first element
1428 of each pair is the package to replace, and the second one is the replacement.
1430 Optionally, REWRITE-NAME is a one-argument procedure that takes the name of a
1431 package and returns its new name after rewrite."
1432 (define replacement-property
1433 ;; Property to tag right-hand sides in REPLACEMENTS.
1434 (gensym " package-replacement"))
1437 (if (assq-ref (package-properties p) replacement-property)
1439 (match (assq-ref replacements p)
1440 (#f (package/inherit p
1441 (name (rewrite-name (package-name p)))))
1443 (package/inherit new
1444 (properties `((,replacement-property . #t)
1445 ,@(package-properties new))))
1449 (or (assq-ref (package-properties p) replacement-property)
1450 (assq-ref replacements p)))
1452 (package-mapping rewrite cut?
1455 (define* (package-input-rewriting/spec replacements #:key (deep? #t))
1456 "Return a procedure that, given a package, applies the given REPLACEMENTS to
1457 all the package graph, including implicit inputs unless DEEP? is false.
1458 REPLACEMENTS is a list of spec/procedures pair; each spec is a package
1459 specification such as \"gcc\" or \"guile@2\", and each procedure takes a
1460 matching package and returns a replacement for that package."
1462 (fold (lambda (replacement table)
1465 (let-values (((name version)
1466 (package-name->name+version spec)))
1467 (vhash-cons name (list version proc) table)))))
1471 (define (find-replacement package)
1472 (vhash-fold* (lambda (item proc)
1478 (and (version-prefix? version
1479 (package-version package))
1482 (package-name package)
1485 (define replacement-property
1486 (gensym " package-replacement"))
1489 (if (assq-ref (package-properties p) replacement-property)
1491 (match (find-replacement p)
1494 (let ((new (proc p)))
1495 ;; Mark NEW as already processed.
1496 (package/inherit new
1497 (properties `((,replacement-property . #t)
1498 ,@(package-properties new)))))))))
1501 (or (assq-ref (package-properties p) replacement-property)
1502 (find-replacement p)))
1504 (package-mapping rewrite cut?
1509 ;;; Package derivations.
1512 (define (cache! cache package system thunk)
1513 "Memoize in CACHE the return values of THUNK as the derivation of PACKAGE on
1515 ;; FIXME: This memoization should be associated with the open store, because
1516 ;; otherwise it breaks when switching to a different store.
1517 (let ((result (thunk)))
1518 ;; Use `hashq-set!' instead of `hash-set!' because `hash' returns the
1519 ;; same value for all structs (as of Guile 2.0.6), and because pointer
1520 ;; equality is sufficient in practice.
1521 (hashq-set! cache package
1522 `((,system . ,result)
1523 ,@(or (hashq-ref cache package) '())))
1526 (define-syntax cached
1528 "Memoize the result of BODY for the arguments PACKAGE and SYSTEM.
1529 Return the cached result when available."
1530 ((_ (=> cache) package system body ...)
1531 (let ((thunk (lambda () body ...))
1533 (match (hashq-ref cache package)
1535 (match (assoc-ref alist key)
1536 (#f (cache! cache package key thunk))
1539 (cache! cache package key thunk)))))))
1541 (define* (expand-input package input system #:key target)
1542 "Expand INPUT, an input tuple, to a name/<gexp-input> tuple. PACKAGE is
1543 only used to provide contextual information in exceptions."
1544 (with-monad %store-monad
1546 ;; INPUT doesn't need to be lowered here because it'll be lowered down
1547 ;; the road in the gexp that refers to it. However, packages need to be
1548 ;; special-cased to pass #:graft? #f (only the "tip" of the package
1549 ;; graph needs to have #:graft? #t). Lowering them here also allows
1550 ;; 'bag->derivation' to delete non-eq? packages that lead to the same
1552 (((? string? name) (? package? package))
1553 (mlet %store-monad ((drv (if target
1554 (package->cross-derivation package
1557 (package->derivation package system
1559 (return (list name (gexp-input drv #:native? (not target))))))
1560 (((? string? name) (? package? package) (? string? output))
1561 (mlet %store-monad ((drv (if target
1562 (package->cross-derivation package
1565 (package->derivation package system
1567 (return (list name (gexp-input drv output #:native? (not target))))))
1569 (((? string? name) (? file-like? thing))
1570 (return (list name (gexp-input thing #:native? (not target)))))
1571 (((? string? name) (? file-like? thing) (? string? output))
1572 (return (list name (gexp-input thing output #:native? (not target)))))
1574 (and (? string?) (? file-exists? file)))
1575 ;; Add FILE to the store. When FILE is in the sub-directory of a
1576 ;; store path, it needs to be added anyway, so it can be used as a
1578 (return (list name (gexp-input (local-file file #:recursive? #t)
1579 #:native? (not target)))))
1581 (raise (condition (&package-input-error
1586 ;; 'eq?' cache mapping packages to system+target+graft?-dependent bags.
1587 ;; It significantly speeds things up when doing repeated calls to
1588 ;; 'package->bag' as is the case when building a profile.
1589 (make-weak-key-hash-table 200))
1591 (define* (package->bag package #:optional
1592 (system (%current-system))
1593 (target (%current-target-system))
1594 #:key (graft? (%graft?)))
1595 "Compile PACKAGE into a bag for SYSTEM, possibly cross-compiled to TARGET,
1597 (let ((package (or (and graft? (package-replacement package))
1599 (cached (=> %bag-cache)
1600 package (list system target)
1601 ;; Bind %CURRENT-SYSTEM and %CURRENT-TARGET-SYSTEM so that thunked
1602 ;; field values can refer to it.
1603 (parameterize ((%current-system system)
1604 (%current-target-system target))
1607 ($ <package> name version source build-system
1608 args inputs propagated-inputs native-inputs
1610 ;; Even though we prefer to use "@" to separate the package
1611 ;; name from the package version in various user-facing parts
1612 ;; of Guix, checkStoreName (in nix/libstore/store-api.cc)
1613 ;; prohibits the use of "@", so use "-" instead.
1614 (or (make-bag build-system (string-append name "-" version)
1618 #:inputs (append (inputs self)
1619 (propagated-inputs self))
1621 #:native-inputs (native-inputs self)
1622 #:arguments (args self))
1625 (&package-cross-build-system-error
1629 (package package))))))))))))
1631 (define %package-graft-cache
1632 ;; Cache mapping <package> records to <graft> records, for packages that
1633 ;; have a replacement.
1634 (allocate-store-connection-cache 'package-graft-cache))
1636 (define (input-graft system)
1637 "Return a monadic procedure that, given a package with a graft, returns a
1638 graft, and #f otherwise."
1639 (with-monad %store-monad
1641 (((? package? package) output)
1642 (let ((replacement (package-replacement package)))
1644 (mcached eq? (=> %package-graft-cache)
1645 (mlet %store-monad ((orig (package->derivation package system
1647 (new (package->derivation replacement system
1651 (origin-output output)
1653 (replacement-output output))))
1654 package output system)
1659 (define (input-cross-graft target system)
1660 "Same as 'input-graft', but for cross-compilation inputs."
1661 (with-monad %store-monad
1663 (((? package? package) output)
1664 (let ((replacement (package-replacement package)))
1666 (mlet %store-monad ((orig (package->cross-derivation package
1669 (new (package->cross-derivation replacement
1674 (origin-output output)
1676 (replacement-output output))))
1681 (define* (fold-bag-dependencies proc seed bag
1683 "Fold PROC over the packages BAG depends on. Each package is visited only
1684 once, in depth-first order. If NATIVE? is true, restrict to native
1685 dependencies; otherwise, restrict to target dependencies."
1686 (define bag-direct-inputs*
1689 (append (bag-build-inputs bag)
1690 (bag-target-inputs bag)
1691 (if (bag-target bag)
1693 (bag-host-inputs bag))))
1696 (let loop ((inputs (bag-direct-inputs* bag))
1698 (visited vlist-null))
1702 (((label (? package? head) . rest) . tail)
1703 (let ((output (match rest (() "out") ((output) output)))
1704 (outputs (vhash-foldq* cons '() head visited)))
1705 (if (member output outputs)
1706 (loop tail result visited)
1707 (let ((inputs (bag-direct-inputs* (package->bag head))))
1708 (loop (append inputs tail)
1709 (proc head output result)
1710 (vhash-consq head output visited))))))
1712 (loop tail result visited)))))
1714 (define* (bag-grafts bag)
1715 "Return the list of grafts potentially applicable to BAG. Potentially
1716 applicable grafts are collected by looking at direct or indirect dependencies
1717 of BAG that have a 'replacement'. Whether a graft is actually applicable
1718 depends on whether the outputs of BAG depend on the items the grafts refer
1719 to (see 'graft-derivation'.)"
1720 (define system (bag-system bag))
1721 (define target (bag-target bag))
1725 (let ((->graft (input-graft system)))
1726 (parameterize ((%current-system system)
1727 (%current-target-system #f))
1728 (fold-bag-dependencies (lambda (package output grafts)
1729 (mlet %store-monad ((grafts grafts))
1730 (>>= (->graft package output)
1732 (#f (return grafts))
1733 (graft (return (cons graft grafts)))))))
1739 (let ((->graft (input-cross-graft target system)))
1740 (parameterize ((%current-system system)
1741 (%current-target-system target))
1742 (fold-bag-dependencies
1743 (lambda (package output grafts)
1744 (mlet %store-monad ((grafts grafts))
1745 (>>= (->graft package output)
1747 (#f (return grafts))
1748 (graft (return (cons graft grafts)))))))
1754 ;; We can end up with several identical grafts if we stumble upon packages
1755 ;; that are not 'eq?' but map to the same derivation (this can happen when
1756 ;; using things like 'package-with-explicit-inputs'.) Hence the
1757 ;; 'delete-duplicates' call.
1758 (return (delete-duplicates
1759 (append native-grafts target-grafts)))))
1761 (define* (package-grafts* package
1762 #:optional (system (%current-system))
1764 "Return the list of grafts applicable to PACKAGE as built for SYSTEM and
1766 (let* ((package (or (package-replacement package) package))
1767 (bag (package->bag package system target)))
1770 (define package-grafts
1771 (store-lower package-grafts*))
1773 (define-inlinable (derivation=? drv1 drv2)
1774 "Return true if DRV1 and DRV2 are equal."
1776 (string=? (derivation-file-name drv1)
1777 (derivation-file-name drv2))))
1779 (define (input=? input1 input2)
1780 "Return true if INPUT1 and INPUT2 are equivalent."
1782 ((label1 obj1 . outputs1)
1784 ((label2 obj2 . outputs2)
1785 (and (string=? label1 label2)
1786 (equal? outputs1 outputs2)
1787 (or (and (derivation? obj1) (derivation? obj2)
1788 (derivation=? obj1 obj2))
1789 (equal? obj1 obj2))))))))
1791 (define* (bag->derivation bag #:optional context)
1792 "Return the derivation to build BAG for SYSTEM. Optionally, CONTEXT can be
1793 a package object describing the context in which the call occurs, for improved
1795 (if (bag-target bag)
1796 (bag->cross-derivation bag)
1797 (mlet* %store-monad ((system -> (bag-system bag))
1798 (inputs -> (bag-transitive-inputs bag))
1799 (input-drvs (mapm %store-monad
1800 (cut expand-input context <> system)
1802 (paths -> (delete-duplicates
1803 (append-map (match-lambda
1804 ((_ (? package? p) _ ...)
1805 (package-native-search-paths
1809 ;; It's possible that INPUTS contains packages that are not 'eq?' but
1810 ;; that lead to the same derivation. Delete those duplicates to avoid
1811 ;; issues down the road, such as duplicate entries in '%build-inputs'.
1812 (apply (bag-build bag) (bag-name bag)
1813 (delete-duplicates input-drvs input=?)
1814 #:search-paths paths
1815 #:outputs (bag-outputs bag) #:system system
1816 (bag-arguments bag)))))
1818 (define* (bag->cross-derivation bag #:optional context)
1819 "Return the derivation to build BAG, which is actually a cross build.
1820 Optionally, CONTEXT can be a package object denoting the context of the call.
1821 This is an internal procedure."
1822 (mlet* %store-monad ((system -> (bag-system bag))
1823 (target -> (bag-target bag))
1824 (host -> (bag-transitive-host-inputs bag))
1825 (host-drvs (mapm %store-monad
1826 (cut expand-input context <>
1827 system #:target target)
1829 (target* -> (bag-transitive-target-inputs bag))
1830 (target-drvs (mapm %store-monad
1831 (cut expand-input context <> system)
1833 (build -> (bag-transitive-build-inputs bag))
1834 (build-drvs (mapm %store-monad
1835 (cut expand-input context <> system)
1837 (all -> (append build target* host))
1838 (paths -> (delete-duplicates
1839 (append-map (match-lambda
1840 ((_ (? package? p) _ ...)
1841 (package-search-paths p))
1844 (npaths -> (delete-duplicates
1845 (append-map (match-lambda
1846 ((_ (? package? p) _ ...)
1847 (package-native-search-paths
1852 (apply (bag-build bag) (bag-name bag)
1853 #:build-inputs (delete-duplicates build-drvs input=?)
1854 #:host-inputs (delete-duplicates host-drvs input=?)
1855 #:target-inputs (delete-duplicates target-drvs input=?)
1856 #:search-paths paths
1857 #:native-search-paths npaths
1858 #:outputs (bag-outputs bag)
1859 #:system system #:target target
1860 (bag-arguments bag))))
1862 (define bag->derivation*
1863 (store-lower bag->derivation))
1865 (define graft-derivation*
1866 (store-lift graft-derivation))
1868 (define* (package->derivation package
1869 #:optional (system (%current-system))
1870 #:key (graft? (%graft?)))
1871 "Return the <derivation> object of PACKAGE for SYSTEM."
1873 ;; Compute the derivation and cache the result. Caching is important
1874 ;; because some derivations, such as the implicit inputs of the GNU build
1875 ;; system, will be queried many, many times in a row.
1876 (mcached (mlet* %store-monad ((bag -> (package->bag package system #f
1878 (drv (bag->derivation bag package)))
1880 (>>= (bag-grafts bag)
1885 (mlet %store-monad ((guile (package->derivation
1887 system #:graft? #f)))
1888 (graft-derivation* drv grafts
1892 package system #f graft?))
1894 (define* (package->cross-derivation package target
1895 #:optional (system (%current-system))
1896 #:key (graft? (%graft?)))
1897 "Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix
1898 system identifying string)."
1899 (mcached (mlet* %store-monad ((bag -> (package->bag package system target
1901 (drv (bag->derivation bag package)))
1903 (>>= (bag-grafts bag)
1908 (mlet %store-monad ((guile (package->derivation
1910 system #:graft? #f)))
1911 (graft-derivation* drv grafts
1915 package system target graft?))
1917 (define* (package-output store package
1918 #:optional (output "out") (system (%current-system)))
1919 "Return the output path of PACKAGE's OUTPUT for SYSTEM---where OUTPUT is the
1920 symbolic output name, such as \"out\". Note that this procedure calls
1921 `package-derivation', which is costly."
1922 (let ((drv (package-derivation store package system)))
1923 (derivation->output-path drv output)))
1927 ;;; Monadic interface.
1930 (define (set-guile-for-build guile)
1931 "This monadic procedure changes the Guile currently used to run the build
1932 code of derivations to GUILE, a package object."
1934 (let ((guile (package-derivation store guile)))
1935 (values (%guile-for-build guile) store))))
1937 (define* (package-file package
1940 system (output "out") target)
1941 "Return as a monadic value the absolute file name of FILE within the
1942 OUTPUT directory of PACKAGE. When FILE is omitted, return the name of the
1943 OUTPUT directory of PACKAGE. When TARGET is true, use it as a
1944 cross-compilation target triplet.
1946 Note that this procedure does _not_ build PACKAGE. Thus, the result might or
1947 might not designate an existing file. We recommend not using this procedure
1948 unless you know what you are doing."
1950 (define compute-derivation
1952 (cut package-cross-derivation <> <> target <>)
1953 package-derivation))
1955 (let* ((system (or system (%current-system)))
1956 (drv (compute-derivation store package system))
1957 (out (derivation->output-path drv output)))
1959 (string-append out "/" file)
1963 (define package-derivation
1964 (store-lower package->derivation))
1966 (define package-cross-derivation
1967 (store-lower package->cross-derivation))
1969 (define-gexp-compiler (package-compiler (package <package>) system target)
1970 ;; Compile PACKAGE to a derivation for SYSTEM, optionally cross-compiled for
1971 ;; TARGET. This is used when referring to a package from within a gexp.
1973 (package->cross-derivation package target system)
1974 (package->derivation package system)))
1976 (define* (origin->derivation origin
1977 #:optional (system (%current-system)))
1978 "Return the derivation corresponding to ORIGIN."
1980 (($ <origin> uri method hash name (= force ()) #f)
1981 ;; No patches, no snippet: this is a fixed-output derivation.
1983 (content-hash-algorithm hash)
1984 (content-hash-value hash)
1985 name #:system system))
1986 (($ <origin> uri method hash name (= force (patches ...)) snippet
1987 flags inputs (modules ...) guile-for-build)
1988 ;; Patches and/or a snippet.
1989 (mlet %store-monad ((source (method uri
1990 (content-hash-algorithm hash)
1991 (content-hash-value hash)
1992 name #:system system))
1993 (guile (package->derivation (or guile-for-build
1997 (patch-and-repack source patches
2003 #:guile-for-build guile)))))
2005 (define-gexp-compiler (origin-compiler (origin <origin>) system target)
2006 ;; Compile ORIGIN to a derivation for SYSTEM. This is used when referring
2007 ;; to an origin from within a gexp.
2008 (origin->derivation origin system))
2010 (define package-source-derivation ;somewhat deprecated
2011 (let ((lower (store-lower lower-object)))
2012 (lambda* (store source #:optional (system (%current-system)))
2013 "Return the derivation or file corresponding to SOURCE, which can be an
2014 a file name or any object handled by 'lower-object', such as an <origin>.
2015 When SOURCE is a file name, return either the interned file name (if SOURCE is
2016 outside of the store) or SOURCE itself (if SOURCE is already a store item.)"
2018 ((and (? string?) (? direct-store-path?) file)
2021 (add-to-store store (basename file) #t "sha256" file))
2023 (lower store source system))))))