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 diagnostics)
45 #:select (formatted-message define-with-syntax-properties))
46 #:autoload (guix licenses) (license?)
47 #:use-module (guix i18n)
48 #:use-module (ice-9 match)
49 #:use-module (ice-9 vlist)
50 #:use-module (ice-9 regex)
51 #:use-module (srfi srfi-1)
52 #:use-module (srfi srfi-9 gnu)
53 #:use-module (srfi srfi-11)
54 #:use-module (srfi srfi-26)
55 #:use-module (srfi srfi-34)
56 #:use-module (srfi srfi-35)
57 #:use-module (rnrs bytevectors)
58 #:use-module (web uri)
59 #:autoload (texinfo) (texi-fragment->stexi)
60 #:re-export (%current-system
61 %current-target-system
62 search-path-specification) ;for convenience
63 #:replace ((define-public* . define-public))
64 #:export (content-hash
66 content-hash-algorithm
75 origin-sha256 ;deprecated
77 origin-actual-file-name
99 package-propagated-inputs
101 package-native-search-paths
108 package-supported-systems
111 package-definition-location
116 package-field-location
119 this-package-native-input
122 lookup-package-native-input
123 lookup-package-propagated-input
124 lookup-package-direct-input
126 prepend ;syntactic keyword
127 replace ;syntactic keyword
130 package-direct-sources
131 package-transitive-sources
132 package-direct-inputs
133 package-transitive-inputs
134 package-transitive-target-inputs
135 package-transitive-native-inputs
136 package-transitive-propagated-inputs
137 package-transitive-native-search-paths
138 package-transitive-supported-systems
140 package-input-rewriting
141 package-input-rewriting/spec
142 package-source-derivation
144 package-cross-derivation
147 package-patched-vulnerabilities
149 package-with-extra-patches
150 package-with-c-toolchain
153 transitive-input-references
155 %32bit-supported-systems
156 %64bit-supported-systems
159 %cuirass-supported-systems
164 package-error-package
165 package-license-error?
166 package-error-invalid-license
169 package-error-invalid-input
170 &package-cross-build-system-error
171 package-cross-build-system-error?
176 bag-transitive-inputs
177 bag-transitive-host-inputs
178 bag-transitive-build-inputs
179 bag-transitive-target-inputs
180 package-development-inputs
184 default-guile-derivation
188 package->cross-derivation
191 ;; The 'source-module-closure' procedure ca. 1.2.0 did not recognize
192 ;; #:re-export-and-replace: <https://issues.guix.gnu.org/52694>.
193 ;; Work around it. The #:replace? argument is only supported by
194 ;; Guile 2.2.7 and later, work-around it if necessary to allow
195 ;; time-travel from 1.1.0, see <https://issues.guix.gnu.org/53765>.
196 (let ((major (string->number (major-version))))
199 (= (string->number (minor-version)) 2) ; there is no Guile 2.3.X
200 (>= (string->number (micro-version)) 7)))
201 (module-re-export! (current-module) '(delete) #:replace? #t)
202 (module-re-export! (current-module) '(delete))))
206 ;;; This module provides a high-level mechanism to define packages in a
207 ;;; Guix-based distribution.
211 (define-syntax-rule (define-compile-time-decoder name string->bytevector)
212 "Define NAME as a macro that runs STRING->BYTEVECTOR at macro expansion time
216 "Return the bytevector corresponding to the given textual
220 (string? (syntax->datum #'str))
221 ;; A literal string: do the conversion at expansion time.
222 (with-syntax ((bv (string->bytevector (syntax->datum #'str))))
225 #'(string->bytevector str))))))
227 (define-compile-time-decoder base32 nix-base32-string->bytevector)
228 (define-compile-time-decoder base64 base64-decode)
230 ;; Crytographic content hash.
231 (define-immutable-record-type <content-hash>
232 (%content-hash algorithm value)
234 (algorithm content-hash-algorithm) ;symbol
235 (value content-hash-value)) ;bytevector
237 (define-syntax-rule (define-content-hash-constructor name
238 (algorithm size) ...)
239 "Define NAME as a <content-hash> constructor that ensures that (1) its
240 second argument is among the listed ALGORITHM, and (2), when possible, that
241 its first argument has the right size for the chosen algorithm."
244 (syntax-case s (algorithm ...)
246 (let ((bv* (syntax->datum #'bv)))
247 (when (and (bytevector? bv*)
248 (not (= size (bytevector-length bv*))))
249 (syntax-violation 'content-hash "invalid content hash length" s))
250 #'(%content-hash 'algorithm bv)))
253 (define-content-hash-constructor build-content-hash
260 (define-syntax content-hash
262 "Return a content hash with the given parameters. The default hash
263 algorithm is sha256. If the first argument is a literal string, it is decoded
264 as base32. Otherwise, it must be a bytevector."
265 ;; What we'd really want here is something like C++ 'constexpr'.
268 (string? (syntax->datum #'str))
269 #'(content-hash str sha256))
271 (string? (syntax->datum #'str))
272 (with-syntax ((bv (base32 (syntax->datum #'str))))
273 #'(content-hash bv algorithm)))
274 ((_ (id str) algorithm)
275 (and (string? (syntax->datum #'str))
276 (free-identifier=? #'id #'base32))
277 (with-syntax ((bv (nix-base32-string->bytevector (syntax->datum #'str))))
278 #'(content-hash bv algorithm)))
279 ((_ (id str) algorithm)
280 (and (string? (syntax->datum #'str))
281 (free-identifier=? #'id #'base64))
282 (with-syntax ((bv (base64-decode (syntax->datum #'str))))
283 #'(content-hash bv algorithm)))
285 #'(content-hash bv sha256))
287 #'(build-content-hash bv hash)))))
289 (define (print-content-hash hash port)
290 (format port "#<content-hash ~a:~a>"
291 (content-hash-algorithm hash)
292 (and=> (content-hash-value hash)
293 bytevector->nix-base32-string)))
295 (set-record-type-printer! <content-hash> print-content-hash)
298 ;; The source of a package, such as a tarball URL and fetcher---called
299 ;; "origin" to avoid name clash with `package-source', `source', etc.
300 (define-record-type* <origin>
304 (uri origin-uri) ; string
305 (method origin-method) ; procedure
306 (hash origin-hash) ; <content-hash>
307 (file-name origin-file-name (default #f)) ; optional file name
309 ;; Patches are delayed so that the 'search-patch' calls are made lazily,
310 ;; which reduces I/O on startup and allows patch-not-found errors to be
311 ;; gracefully handled at run time.
312 (patches origin-patches ; list of file names
313 (default '()) (delayed))
315 (snippet origin-snippet (default #f)) ; sexp or #f
316 (patch-flags origin-patch-flags ; string-list gexp
317 (default %default-patch-flags))
319 ;; Patching requires Guile, GNU Patch, and a few more. These two fields are
320 ;; used to specify these dependencies when needed.
321 (patch-inputs origin-patch-inputs ; input list or #f
323 (modules origin-modules ; list of module names
326 (patch-guile origin-patch-guile ; package or #f
329 (define-syntax origin-compatibility-helper
330 (syntax-rules (sha256)
332 (%origin fields ...))
333 ((_ ((sha256 exp) rest ...) (others ...))
335 (hash (content-hash exp sha256))
337 ((_ (field rest ...) (others ...))
338 (origin-compatibility-helper (rest ...)
339 (others ... field)))))
341 (define-syntax-rule (origin fields ...)
342 "Build an <origin> record, automatically converting 'sha256' field
343 specifications to 'hash'."
344 (origin-compatibility-helper (fields ...) ()))
346 (define-deprecated (origin-sha256 origin)
348 (let ((hash (origin-hash origin)))
349 (unless (eq? (content-hash-algorithm hash) 'sha256)
350 (raise (condition (&message
351 (message (G_ "no SHA256 hash for origin"))))))
352 (content-hash-value hash)))
354 (define (print-origin origin port)
355 "Write a concise representation of ORIGIN to PORT."
357 (($ <origin> uri method hash file-name patches)
358 (simple-format port "#<origin ~s ~a ~s ~a>"
361 (number->string (object-address origin) 16)))))
363 (set-record-type-printer! <origin> print-origin)
365 (define %default-patch-flags
368 (define (origin-actual-file-name origin)
369 "Return the file name of ORIGIN, either its 'file-name' field or the file
371 (define (uri->file-name uri)
372 ;; Return the 'base name' of URI or URI itself, where URI is a string.
373 (let ((path (and=> (string->uri uri) uri-path)))
378 (or (origin-file-name origin)
379 (match (origin-uri origin)
381 (uri->file-name head))
383 (uri->file-name uri))
385 ;; git, svn, cvs, etc. reference
388 ;; Work around limitations in the 'snippet' mechanism. It is not possible for
389 ;; a 'snippet' to produce a tarball with a different base name than the
390 ;; original downloaded source. Moreover, cherry picking dozens of upsteam
391 ;; patches and applying them suddenly is often impractical; especially when a
392 ;; comprehensive code reformatting is done upstream. Mainly designed for
393 ;; Linux and IceCat packages.
394 ;; XXXX: do not make part of public API (export) such radical capability
395 ;; before a detailed review process.
396 (define* (computed-origin-method gexp-promise hash-algo hash
397 #:optional (name "source")
398 #:key (system (%current-system))
399 (guile (default-guile)))
400 "Return a derivation that executes the G-expression that results
401 from forcing GEXP-PROMISE."
402 (mlet %store-monad ((guile (package->derivation guile system)))
403 (gexp->derivation (or name "computed-origin")
405 #:graft? #f ;nothing to graft
407 #:guile-for-build guile)))
410 (define %32bit-supported-systems
411 ;; This is the list of 32-bit system types that are supported.
412 '("i686-linux" "armhf-linux" "i586-gnu" "powerpc-linux"))
414 (define %64bit-supported-systems
415 ;; This is the list of 64-bit system types that are supported.
416 '("x86_64-linux" "mips64el-linux" "aarch64-linux" "powerpc64le-linux"
419 (define %supported-systems
420 ;; This is the list of system types that are supported. By default, we
421 ;; expect all packages to build successfully here.
422 (append %64bit-supported-systems %32bit-supported-systems))
424 (define %hurd-systems
425 ;; The GNU/Hurd systems for which support is being developed.
426 '("i586-gnu" "i686-gnu"))
428 (define %cuirass-supported-systems
429 ;; This is the list of system types for which build machines are available.
431 ;; XXX: MIPS is unavailable in CI:
432 ;; <https://lists.gnu.org/archive/html/guix-devel/2017-03/msg00790.html>.
433 (fold delete %supported-systems '("mips64el-linux" "powerpc-linux" "riscv64-linux")))
435 (define-inlinable (sanitize-inputs inputs)
436 "Sanitize INPUTS by turning it into a list of name/package tuples if it's
437 not already the case."
438 (cond ((null? inputs) inputs)
439 ((and (pair? (car inputs))
440 (string? (caar inputs)))
442 (else (map add-input-label inputs))))
444 (define-syntax current-location-vector
446 "Like 'current-source-location' but expand to a literal vector with
447 one-indexed line numbers."
448 ;; Storing a literal vector in .go files is more efficient than storing an
449 ;; alist: less initialization code, fewer relocations, etc.
452 (match (syntax-source s)
455 (let ((file (assq-ref properties 'filename))
456 (line (assq-ref properties 'line))
457 (column (assq-ref properties 'column)))
458 (and file line column
459 #`#(#,file #,(+ 1 line) #,column)))))))))
461 (define-inlinable (sanitize-location loc)
462 ;; Convert LOC to a vector or to #f.
463 (cond ((vector? loc) loc)
465 (else (vector (location-file loc)
467 (location-column loc)))))
469 (define-syntax-parameter current-definition-location
470 ;; Location of the encompassing 'define-public'.
473 (define-syntax define-public*
475 "Like 'define-public' but set 'current-definition-location' for the
476 lexical scope of its body."
478 (match (syntax-source s)
481 (let ((line (assq-ref properties 'line))
482 (column (assq-ref properties 'column)))
483 ;; Don't repeat the file name since it's redundant with 'location'.
484 ;; Encode the whole thing so that it fits in a fixnum on 32-bit
485 ;; platforms, which leaves us 29 bits: 7 bits for COLUMN (which is
486 ;; almost always zero), and 22 bits for LINE.
488 (logior (ash (logand #x7f column) 22)
489 (logand (- (expt 2 22) 1) (+ 1 line))))))))
492 ((_ prototype body ...)
493 #`(define-public prototype
494 (syntax-parameterize ((current-definition-location
495 (lambda (s) #,location)))
498 (define-syntax validate-texinfo
499 (let ((validate? (getenv "GUIX_UNINSTALLED")))
500 (define ensure-thread-safe-texinfo-parser!
501 ;; Work around <https://issues.guix.gnu.org/51264> for Guile <= 3.0.7.
502 (let ((patched? (or (> (string->number (major-version)) 3)
503 (> (string->number (minor-version)) 0)
504 (> (string->number (micro-version)) 7)))
505 (next-token-of/thread-safe
507 (let loop ((chars '()))
508 (match (read-char port)
510 (list->string (reverse! chars)))
512 (let ((chr* (pred chr)))
514 (loop (cons chr* chars))
516 (unread-char chr port)
517 (list->string (reverse! chars)))))))))))
520 (set! (@@ (texinfo) next-token-of) next-token-of/thread-safe)
521 (set! patched? #t)))))
524 "Raise a syntax error when passed a literal string that is not valid
525 Texinfo. Otherwise, return the string."
528 (string? (syntax->datum #'str))
532 (ensure-thread-safe-texinfo-parser!)
533 (texi-fragment->stexi (syntax->datum #'str))
536 (syntax-violation 'package "invalid Texinfo markup" #'str)))
541 (define-syntax valid-license-value?
542 (syntax-rules (list package-license)
543 "Return #t if the given value is a valid license field, #f otherwise."
544 ;; Arrange so that the answer can be given at macro-expansion time in the
545 ;; most common cases.
547 (and (license? x) ...))
548 ((_ (package-license _))
552 ;; Note: Avoid 'not' below due to <https://bugs.gnu.org/58217>.
553 (eq? #f obj) ;#f is considered valid
555 (and (pair? x) (every license? x)))))))
557 (define-with-syntax-properties (validate-license (value properties))
558 (unless (valid-license-value? value)
560 (make-compound-condition
563 (location (source-properties->location properties))))
565 (&package-license-error (package #f) (license value)))
566 (formatted-message (G_ "~s: invalid package license~%") value))))
570 (define-record-type* <package>
574 (name package-name) ; string
575 (version package-version) ; string
576 (source package-source) ; <origin> instance
577 (build-system package-build-system) ; <build-system> instance
578 (arguments package-arguments ; arguments for the build method
579 (default '()) (thunked))
581 (inputs package-inputs ; input packages or derivations
582 (default '()) (thunked)
583 (sanitize sanitize-inputs))
584 (propagated-inputs package-propagated-inputs ; same, but propagated
585 (default '()) (thunked)
586 (sanitize sanitize-inputs))
587 (native-inputs package-native-inputs ; native input packages/derivations
588 (default '()) (thunked)
589 (sanitize sanitize-inputs))
591 (outputs package-outputs ; list of strings
595 ; <search-path-specification>,
596 ; for native and cross
598 (native-search-paths package-native-search-paths (default '()))
599 (search-paths package-search-paths (default '()))
601 ;; The 'replacement' field is marked as "innate" because it never makes
602 ;; sense to inherit a replacement as is. See the 'package/inherit' macro.
603 (replacement package-replacement ; package | #f
604 (default #f) (thunked) (innate))
606 (synopsis package-synopsis
607 (sanitize validate-texinfo)) ; one-line description
608 (description package-description
609 (sanitize validate-texinfo)) ; one or two paragraphs
610 (license package-license ; (list of) <license>
611 (sanitize validate-license))
612 (home-page package-home-page)
613 (supported-systems package-supported-systems ; list of strings
614 (default %supported-systems))
616 (properties package-properties (default '())) ; alist for anything else
618 (location package-location-vector
619 (default (current-location-vector))
620 (innate) (sanitize sanitize-location))
621 (definition-location package-definition-location-code
622 (default (current-definition-location))
625 (define (add-input-label input)
626 "Add an input label to INPUT."
628 ((? package? package)
629 (list (package-name package) package))
630 (((? package? package) output) ;XXX: ugly?
631 (list (package-name package) package output))
632 ((? gexp-input?) ;XXX: misplaced because 'native?' field is ignored?
633 (let ((obj (gexp-input-thing input))
634 (output (gexp-input-output input)))
635 `(,(if (package? obj)
639 ,@(if (string=? output "out") '() (list output)))))
643 (set-record-type-printer! <package>
644 (lambda (package port)
645 (let ((loc (package-location package))
646 (format simple-format))
647 (format port "#<package ~a@~a ~a~a>"
648 (package-name package)
649 (package-version package)
655 (number->string (object-address
659 (define (package-location package)
660 "Return the source code location of PACKAGE as a <location> record, or #f if
662 (match (package-location-vector package)
664 (#(file line column) (location file line column))))
666 (define (package-definition-location package)
667 "Like 'package-location', but return the location of the definition
668 itself--i.e., that of the enclosing 'define-public' form, if any, or #f."
669 (match (package-definition-location-code package)
672 (let ((column (bit-extract code 22 29))
673 (line (bit-extract code 0 21)))
674 (match (package-location-vector package)
676 (#(file _ _) (location file line column)))))))
678 (define-syntax-rule (package/inherit p overrides ...)
679 "Like (package (inherit P) OVERRIDES ...), except that the same
680 transformation is done to the package P's replacement, if any. P must be a bare
681 identifier, and will be bound to either P or its replacement when evaluating
686 (replacement (and=> (package-replacement p) loop)))))
688 (define (package-upstream-name package)
689 "Return the upstream name of PACKAGE, which could be different from the name
691 (or (assq-ref (package-properties package) 'upstream-name)
692 (package-name package)))
694 (define (hidden-package p)
695 "Return a \"hidden\" version of P--i.e., one that 'fold-packages' and thus,
696 user interfaces, ignores."
699 (location (package-location p))
700 (properties `((hidden? . #t)
701 ,@(package-properties p)))))
703 (define (hidden-package? p)
704 "Return true if P is \"hidden\"--i.e., must not be visible to user
706 (assoc-ref (package-properties p) 'hidden?))
708 (define (package-superseded p)
709 "Return the package that supersedes P, or #f if P is still current."
710 (assoc-ref (package-properties p) 'superseded))
712 (define (deprecated-package old-name p)
713 "Return a package called OLD-NAME and marked as superseded by P, a package
718 (properties `((superseded . ,p)))))
720 (define (package-field-location package field)
721 "Return the source code location of the definition of FIELD for PACKAGE, or
722 #f if it could not be determined."
723 (match (package-location package)
724 (($ <location> file line column)
725 (match (search-path %load-path file)
726 ((? string? file-found)
729 ;; In general we want to keep relative file names for modules.
730 (call-with-input-file file-found
732 (go-to-location port line column)
734 (('package inits ...)
735 (let ((field (assoc field inits)))
738 (let ((loc (and=> (source-properties value)
739 source-properties->location)))
741 ;; Preserve the original file name, which may be a
742 ;; relative file name.
743 (set-field loc (location-file) file))))
751 ;; FILE could not be found in %LOAD-PATH.
755 (define-syntax-rule (this-package-input name)
756 "Return the input NAME of the package being defined--i.e., an input
757 from the ‘inputs’ or ‘propagated-inputs’ field. Native inputs are not
758 considered. If this input does not exist, return #f instead."
759 (or (lookup-package-input this-package name)
760 (lookup-package-propagated-input this-package name)))
762 (define-syntax-rule (this-package-native-input name)
763 "Return the native package input NAME of the package being defined--i.e.,
764 an input from the ‘native-inputs’ field. If this native input does not
765 exist, return #f instead."
766 (lookup-package-native-input this-package name))
770 (define-condition-type &package-error &error
772 (package package-error-package))
774 (define-condition-type &package-license-error &package-error
775 package-license-error?
776 (license package-error-invalid-license))
778 (define-condition-type &package-input-error &package-error
780 (input package-error-invalid-input))
782 (define-condition-type &package-cross-build-system-error &package-error
783 package-cross-build-system-error?)
785 (define* (package-full-name package #:optional (delimiter "@"))
786 "Return the full name of PACKAGE--i.e., `NAME@VERSION'. By specifying
787 DELIMITER (a string), you can customize what will appear between the name and
788 the version. By default, DELIMITER is \"@\"."
789 (string-append (package-name package) delimiter (package-version package)))
791 (define (patch-file-name patch)
792 "Return the basename of PATCH's file name, or #f if the file name could not
798 (and=> (origin-actual-file-name patch) basename))))
800 (define %vulnerability-regexp
801 ;; Regexp matching a CVE identifier in patch file names.
802 (make-regexp "CVE-[0-9]{4}-[0-9]+"))
804 (define (package-patched-vulnerabilities package)
805 "Return the list of patched vulnerabilities of PACKAGE as a list of CVE
806 identifiers. The result is inferred from the file names of patches."
807 (define (patch-vulnerabilities patch)
808 (map (cut match:substring <> 0)
809 (list-matches %vulnerability-regexp patch)))
811 (let ((patches (filter-map patch-file-name
812 (or (and=> (package-source package)
815 (append-map patch-vulnerabilities patches)))
817 (define (%standard-patch-inputs)
818 (let* ((canonical (module-ref (resolve-interface '(gnu packages base))
820 (ref (lambda (module var)
821 ;; Make sure 'canonical-package' is not influenced by
822 ;; '%current-target-system' since we're going to use the
823 ;; native package anyway.
824 (parameterize ((%current-target-system #f))
826 (module-ref (resolve-interface module) var))))))
827 `(("tar" ,(ref '(gnu packages base) 'tar))
828 ("xz" ,(ref '(gnu packages compression) 'xz))
829 ("bzip2" ,(ref '(gnu packages compression) 'bzip2))
830 ("gzip" ,(ref '(gnu packages compression) 'gzip))
831 ("lzip" ,(ref '(gnu packages compression) 'lzip))
832 ("unzip" ,(ref '(gnu packages compression) 'unzip))
833 ("patch" ,(ref '(gnu packages base) 'patch))
834 ("locales" ,(ref '(gnu packages base) 'glibc-utf8-locales)))))
836 (define (default-guile)
837 "Return the default Guile package used to run the build code of
839 (let ((distro (resolve-interface '(gnu packages commencement))))
840 (module-ref distro 'guile-final)))
842 (define (guile-for-grafts)
843 "Return the Guile package used to build grafting derivations."
844 ;; Guile 2.2 would not work due to <https://bugs.gnu.org/28211> when
845 ;; grafting packages.
846 (let ((distro (resolve-interface '(gnu packages guile))))
847 (module-ref distro 'guile-2.0)))
849 (define* (default-guile-derivation #:optional (system (%current-system)))
850 "Return the derivation for SYSTEM of the default Guile package used to run
851 the build code of derivation."
852 (package->derivation (default-guile) system
855 (define* (patch-and-repack source patches
859 (flags %default-patch-flags)
861 (guile-for-build (%guile-for-build))
862 (system (%current-system)))
863 "Unpack SOURCE (a derivation or store path), apply all of PATCHES, and
864 repack the tarball using the tools listed in INPUTS. When SNIPPET is true,
865 it must be an s-expression that will run from within the directory where
866 SOURCE was unpacked, after all of PATCHES have been applied. MODULES
867 specifies modules in scope when evaluating SNIPPET."
868 (define source-file-name
869 ;; SOURCE is usually a derivation, but it could be a store file.
870 (if (derivation? source)
871 (derivation->output-path source)
875 ;; The default value of the 'patch-inputs' field, and thus INPUTS is #f,
876 ;; so deal with that.
877 (let ((inputs (or inputs (%standard-patch-inputs))))
879 (match (assoc-ref inputs name)
883 (define original-file-name (strip-store-file-name source-file-name))
885 (define (numeric-extension? file-name)
886 ;; Return true if FILE-NAME ends with digits.
887 (and=> (file-extension file-name)
888 (cut string-every char-set:hex-digit <>)))
890 (define (checkout? directory)
891 ;; Return true if DIRECTORY is a checkout (git, svn, etc).
892 (string-suffix? "-checkout" directory))
894 (define (tarxz-name file-name)
895 ;; Return a '.tar.xz' file name based on FILE-NAME.
896 (let ((base (if (numeric-extension? file-name)
898 (file-sans-extension file-name))))
900 (if (equal? (file-extension base) "tar")
904 (define instantiate-patch
906 ((? string? patch) ;deprecated
907 (local-file patch #:recursive? #t))
908 ((? struct? patch) ;origin, local-file, etc.
911 (let ((tar (lookup-input "tar"))
912 (gzip (lookup-input "gzip"))
913 (bzip2 (lookup-input "bzip2"))
914 (lzip (lookup-input "lzip"))
915 (xz (lookup-input "xz"))
916 (patch (lookup-input "patch"))
917 (locales (lookup-input "locales"))
918 (comp (and=> (compressor source-file-name) lookup-input))
919 (patches (map instantiate-patch patches)))
921 (with-imported-modules '((guix build utils))
923 (use-modules (ice-9 ftw)
930 ;; The --sort option was added to GNU tar in version 1.28, released
931 ;; 2014-07-28. During bootstrap we must cope with older versions.
932 (define tar-supports-sort?
933 (zero? (system* (string-append #+tar "/bin/tar")
934 "cf" "/dev/null" "--files-from=/dev/null"
937 (define (apply-patch patch)
938 (format (current-error-port) "applying '~a'...~%" patch)
940 ;; Use '--force' so that patches that do not apply perfectly are
941 ;; rejected. Use '--no-backup-if-mismatch' to prevent making
942 ;; "*.orig" file if a patch is applied with offset.
943 (invoke (string-append #+patch "/bin/patch")
944 "--force" "--no-backup-if-mismatch"
945 #+@flags "--input" patch))
947 (define (first-file directory)
948 ;; Return the name of the first file in DIRECTORY.
949 (car (scandir directory
951 (not (member name '("." "..")))))))
953 (define (repack directory output)
954 ;; Write to OUTPUT a compressed tarball containing DIRECTORY.
955 (unless tar-supports-sort?
956 (call-with-output-file ".file_list"
958 (for-each (lambda (name)
959 (format port "~a~%" name))
960 (find-files directory
962 #:fail-on-error? #t)))))
964 (apply invoke #+(file-append tar "/bin/tar")
966 ;; Avoid non-determinism in the archive. Set the mtime
967 ;; to 1 as is the case in the store (software like gzip
968 ;; behaves differently when it stumbles upon mtime = 0).
970 "--owner=root:0" "--group=root:0"
971 (if tar-supports-sort?
972 `("--sort=name" ,directory)
974 "--files-from=.file_list"))))
976 ;; Encoding/decoding errors shouldn't be silent.
977 (fluid-set! %default-port-conversion-strategy 'error)
980 ;; First of all, install a UTF-8 locale so that UTF-8 file names
981 ;; are correctly interpreted. During bootstrap, LOCALES is #f.
983 (string-append #+locales "/lib/locale/"
986 (package-version locales)))))
987 (setlocale LC_ALL "en_US.utf8"))
990 (string-append #+xz "/bin"
992 (string-append ":" #+comp "/bin")
995 (setenv "XZ_DEFAULTS" (string-join (%xz-parallel-args)))
997 ;; SOURCE may be either a directory, a tarball or a simple file.
998 (let ((name (strip-store-file-name #+source))
999 (command (and=> #+comp (cut string-append <> "/bin/"
1000 (compressor #+source)))))
1001 (if (file-is-directory? #+source)
1002 (copy-recursively #+source name)
1004 ((tarball? #+source)
1005 (invoke (string-append #+tar "/bin/tar") "xvf" #+source))
1006 ((and=> (compressor #+source) (cut string= "unzip" <>))
1007 ;; Note: Referring to the store unzip here (#+unzip)
1008 ;; would introduce a cycle.
1009 (invoke "unzip" #+source))
1011 (copy-file #+source name)
1013 (invoke command "--decompress" name))))))
1015 (let* ((file (first-file "."))
1016 (directory (if (file-is-directory? file)
1019 (format (current-error-port) "source is at '~a'~%" file)
1021 (with-directory-excursion directory
1023 (for-each apply-patch '#+patches)
1026 #~(let ((module (make-fresh-user-module)))
1027 (module-use-interfaces!
1029 (map resolve-interface '#+modules))
1030 ((@ (system base compile) compile)
1031 '#+(if (pair? snippet)
1032 (sexp->gexp snippet)
1035 #:opts %auto-compilation-options
1039 ;; If SOURCE is a directory (such as a checkout), return a
1040 ;; directory. Otherwise create a tarball.
1042 ((file-is-directory? #+source)
1043 (copy-recursively directory #$output
1044 #:log (%make-void-port "w")))
1045 ((or #+comp (tarball? #+source))
1046 (repack directory #$output))
1047 (else ;single uncompressed file
1048 (copy-file file #$output)))))))
1050 (let ((name (if (or (checkout? original-file-name)
1051 (not (compressor original-file-name)))
1053 (tarxz-name original-file-name))))
1054 (gexp->derivation name build
1057 #:guile-for-build guile-for-build
1058 #:properties `((type . origin)
1059 (patches . ,(length patches)))))))
1061 (define (package-with-patches original patches)
1062 "Return package ORIGINAL with PATCHES applied."
1063 (package (inherit original)
1064 (source (origin (inherit (package-source original))
1066 (location (package-location original))))
1068 (define (package-with-extra-patches original patches)
1069 "Return package ORIGINAL with all PATCHES appended to its list of patches."
1070 (package-with-patches original
1071 (append (origin-patches (package-source original))
1074 (define (package-with-c-toolchain package toolchain)
1075 "Return a variant of PACKAGE that uses TOOLCHAIN instead of the default GNU
1076 C/C++ toolchain. TOOLCHAIN must be a list of inputs (label/package tuples)
1077 providing equivalent functionality, such as the 'gcc-toolchain' package."
1078 (let ((bs (package-build-system package)))
1079 (package/inherit package
1080 (build-system (build-system-with-c-toolchain bs toolchain)))))
1082 (define (transitive-inputs inputs)
1083 "Return the closure of INPUTS when considering the 'propagated-inputs'
1084 edges. Omit duplicate inputs, except for those already present in INPUTS
1087 This is implemented as a breadth-first traversal such that INPUTS is
1088 preserved, and only duplicate propagated inputs are removed."
1089 (define (seen? seen item outputs)
1090 ;; FIXME: We're using pointer identity here, which is extremely sensitive
1091 ;; to memoization in package-producing procedures; see
1092 ;; <https://bugs.gnu.org/30155>.
1093 (match (vhash-assq item seen)
1094 ((_ . o) (equal? o outputs))
1097 (let loop ((inputs inputs)
1104 (if (null? propagated)
1106 (loop (reverse (concatenate propagated)) result '() #f seen)))
1107 (((and input (label (? package? package) outputs ...)) rest ...)
1108 (if (and (not first?) (seen? seen package outputs))
1109 (loop rest result propagated first? seen)
1112 (cons (package-propagated-inputs package) propagated)
1114 (vhash-consq package outputs seen))))
1116 (loop rest (cons input result) propagated first? seen)))))
1118 (define (lookup-input inputs name)
1119 "Lookup NAME among INPUTS, an input list."
1120 ;; Note: Currently INPUTS is assumed to be an input list that contains input
1121 ;; labels. In the future, input labels will be gone and this procedure will
1122 ;; check package names.
1123 (match (assoc-ref inputs name)
1128 (define (lookup-package-input package name)
1129 "Look up NAME among PACKAGE's inputs. Return it if found, #f otherwise."
1130 (lookup-input (package-inputs package) name))
1132 (define (lookup-package-native-input package name)
1133 "Look up NAME among PACKAGE's native inputs. Return it if found, #f
1135 (lookup-input (package-native-inputs package) name))
1137 (define (lookup-package-propagated-input package name)
1138 "Look up NAME among PACKAGE's propagated inputs. Return it if found, #f
1140 (lookup-input (package-propagated-inputs package) name))
1142 (define (lookup-package-direct-input package name)
1143 "Look up NAME among PACKAGE's direct inputs. Return it if found, #f
1145 (lookup-input (package-direct-inputs package) name))
1147 (define (replace-input name replacement inputs)
1148 "Replace input NAME by REPLACEMENT within INPUTS."
1149 (map (lambda (input)
1151 (((? string? label) _ . outputs)
1152 (if (string=? label name)
1153 (match replacement ;does REPLACEMENT specify an output?
1154 ((_ _) (cons label replacement))
1155 (_ (cons* label replacement outputs)))
1159 (define-syntax prepend
1161 (syntax-violation 'prepend
1162 "'prepend' may only be used within 'modify-inputs'"
1165 (define-syntax replace
1167 (syntax-violation 'replace
1168 "'replace' may only be used within 'modify-inputs'"
1171 (define-syntax modify-inputs
1172 (syntax-rules (delete prepend append replace)
1173 "Modify the given package inputs, as returned by 'package-inputs' & co.,
1174 according to the given clauses. The example below removes the GMP and ACL
1175 inputs of Coreutils and adds libcap:
1177 (modify-inputs (package-inputs coreutils)
1178 (delete \"gmp\" \"acl\")
1181 Other types of clauses include 'prepend' and 'replace'.
1183 The first argument must be a labeled input list; the result is also a labeled
1185 ;; Note: This macro hides the fact that INPUTS, as returned by
1186 ;; 'package-inputs' & co., is actually an alist with labels. Eventually,
1187 ;; it will operate on list of inputs without labels.
1188 ((_ inputs (delete name) clauses ...)
1189 (modify-inputs (alist-delete name inputs)
1191 ((_ inputs (delete names ...) clauses ...)
1192 (modify-inputs (fold alist-delete inputs (list names ...))
1194 ((_ inputs (prepend lst ...) clauses ...)
1195 (modify-inputs (append (map add-input-label (list lst ...)) inputs)
1197 ((_ inputs (append lst ...) clauses ...)
1198 (modify-inputs (append inputs (map add-input-label (list lst ...)))
1200 ((_ inputs (replace name replacement) clauses ...)
1201 (modify-inputs (replace-input name replacement inputs)
1206 (define (package-direct-sources package)
1207 "Return all source origins associated with PACKAGE; including origins in
1209 `(,@(or (and=> (package-source package) list) '())
1210 ,@(filter-map (match-lambda
1211 ((_ (? origin? orig) _ ...)
1214 (package-direct-inputs package))))
1216 (define (package-transitive-sources package)
1217 "Return PACKAGE's direct sources, and their direct sources, recursively."
1219 (concatenate (filter-map (match-lambda
1220 ((_ (? origin? orig) _ ...)
1222 ((_ (? package? p) _ ...)
1223 (package-direct-sources p))
1225 (bag-transitive-inputs
1226 (package->bag package))))))
1228 (define (package-direct-inputs package)
1229 "Return all the direct inputs of PACKAGE---i.e, its direct inputs along
1230 with their propagated inputs."
1231 (append (package-native-inputs package)
1232 (package-inputs package)
1233 (package-propagated-inputs package)))
1235 (define (package-transitive-inputs package)
1236 "Return the transitive inputs of PACKAGE---i.e., its direct inputs along
1237 with their propagated inputs, recursively."
1238 (transitive-inputs (package-direct-inputs package)))
1240 (define (package-transitive-target-inputs package)
1241 "Return the transitive target inputs of PACKAGE---i.e., its direct inputs
1242 along with their propagated inputs, recursively. This only includes inputs
1243 for the target system, and not native inputs."
1244 (transitive-inputs (append (package-inputs package)
1245 (package-propagated-inputs package))))
1247 (define (package-transitive-native-inputs package)
1248 "Return the transitive native inputs of PACKAGE---i.e., its direct inputs
1249 along with their propagated inputs, recursively. This only includes inputs
1250 for the host system (\"native inputs\"), and not target inputs."
1251 (transitive-inputs (package-native-inputs package)))
1253 (define (package-transitive-propagated-inputs package)
1254 "Return the propagated inputs of PACKAGE, and their propagated inputs,
1256 (transitive-inputs (package-propagated-inputs package)))
1258 (define (package-transitive-native-search-paths package)
1259 "Return the list of search paths for PACKAGE and its propagated inputs,
1261 (append (package-native-search-paths package)
1262 (append-map (match-lambda
1263 ((label (? package? p) _ ...)
1264 (package-native-search-paths p))
1267 (package-transitive-propagated-inputs package))))
1269 (define (transitive-input-references alist inputs)
1270 "Return a list of (assoc-ref ALIST <label>) for each (<label> <package> . _)
1271 in INPUTS and their transitive propagated inputs."
1277 (map (lambda (input)
1278 `(assoc-ref ,alist ,(label input)))
1279 (transitive-inputs inputs)))
1281 (define package-transitive-supported-systems
1283 (define (supported-systems-procedure system)
1284 (define supported-systems
1286 (parameterize ((%current-system system))
1287 (fold (lambda (input systems)
1289 ((label (? package? package) . _)
1290 (lset-intersection string=? systems
1291 (supported-systems package)))
1294 (package-supported-systems package)
1295 (bag-direct-inputs (package->bag package system #f))))))
1300 ;; Map system strings to one-argument procedures. This allows these
1301 ;; procedures to have fast 'eq?' memoization on their argument.
1304 (lambda* (package #:optional (system (%current-system)))
1305 "Return the intersection of the systems supported by PACKAGE and those
1306 supported by its dependencies."
1307 (match (hash-ref procs system)
1309 (hash-set! procs system (supported-systems-procedure system))
1310 (package-transitive-supported-systems package system))
1314 (define* (supported-package? package #:optional (system (%current-system)))
1315 "Return true if PACKAGE is supported on SYSTEM--i.e., if PACKAGE and all its
1316 dependencies are known to build on SYSTEM."
1317 (member system (package-transitive-supported-systems package system)))
1319 (define (bag-direct-inputs bag)
1320 "Same as 'package-direct-inputs', but applied to a bag."
1321 (append (bag-build-inputs bag)
1322 (bag-host-inputs bag)
1323 (bag-target-inputs bag)))
1325 (define (bag-transitive-inputs bag)
1326 "Same as 'package-transitive-inputs', but applied to a bag."
1327 (parameterize ((%current-target-system #f)
1328 (%current-system (bag-system bag)))
1329 (transitive-inputs (bag-direct-inputs bag))))
1331 (define (bag-transitive-build-inputs bag)
1332 "Same as 'package-transitive-native-inputs', but applied to a bag."
1333 (parameterize ((%current-target-system #f)
1334 (%current-system (bag-system bag)))
1335 (transitive-inputs (bag-build-inputs bag))))
1337 (define (bag-transitive-host-inputs bag)
1338 "Same as 'package-transitive-target-inputs', but applied to a bag."
1339 (parameterize ((%current-target-system (bag-target bag))
1340 (%current-system (bag-system bag)))
1341 (transitive-inputs (bag-host-inputs bag))))
1343 (define (bag-transitive-target-inputs bag)
1344 "Return the \"target inputs\" of BAG, recursively."
1345 (parameterize ((%current-target-system (bag-target bag))
1346 (%current-system (bag-system bag)))
1347 (transitive-inputs (bag-target-inputs bag))))
1349 (define* (package-development-inputs package
1350 #:optional (system (%current-system))
1352 "Return the list of inputs required by PACKAGE for development purposes on
1353 SYSTEM. When TARGET is true, return the inputs needed to cross-compile
1354 PACKAGE from SYSTEM to TRIPLET, where TRIPLET is a triplet such as
1355 \"aarch64-linux-gnu\"."
1356 (bag-transitive-inputs (package->bag package system target)))
1358 (define* (package-closure packages #:key (system (%current-system)))
1359 "Return the closure of PACKAGES on SYSTEM--i.e., PACKAGES and the list of
1360 packages they depend on, recursively."
1361 (let loop ((packages packages)
1362 (visited vlist-null)
1363 (closure (list->setq packages)))
1366 (set->list closure))
1368 (if (vhash-assq package visited)
1369 (loop rest visited closure)
1370 (let* ((bag (package->bag package system))
1371 (dependencies (filter-map (match-lambda
1372 ((label (? package? package) . _)
1375 (bag-direct-inputs bag))))
1376 (loop (append dependencies rest)
1377 (vhash-consq package #t visited)
1378 (fold set-insert closure dependencies))))))))
1380 (define (build-system-with-package-mapping bs rewrite)
1381 "Return a variant of BS, a build system, that rewrites a bag's inputs by
1382 passing them through REWRITE, a procedure that takes an input tuplet and
1383 returns a \"rewritten\" input tuplet."
1385 (build-system-lower bs))
1387 (define (lower* . args)
1388 (let ((lowered (apply lower args)))
1391 (build-inputs (map rewrite (bag-build-inputs lowered)))
1392 (host-inputs (map rewrite (bag-host-inputs lowered)))
1393 (target-inputs (map rewrite (bag-target-inputs lowered))))))
1399 (define* (package-mapping proc #:optional (cut? (const #f))
1401 "Return a procedure that, given a package, applies PROC to all the packages
1402 depended on and returns the resulting package. The procedure stops recursion
1403 when CUT? returns true for a given package. When DEEP? is true, PROC is
1404 applied to implicit inputs as well."
1405 (define (rewrite input)
1407 ((label (? package? package) outputs ...)
1408 (cons* label (replace package) outputs))
1412 (define mapping-property
1413 ;; Property indicating whether the package has already been processed.
1414 (gensym " package-mapping-done"))
1418 ;; If P is the result of a previous call, return it.
1419 (cond ((assq-ref (package-properties p) mapping-property)
1423 ;; Since P's propagated inputs are really inputs of its dependents,
1424 ;; rewrite them as well, unless we're doing a "shallow" rewrite.
1427 (null? (package-propagated-inputs p)))
1431 (location (package-location p))
1432 (replacement (package-replacement p))
1433 (propagated-inputs (map rewrite (package-propagated-inputs p)))
1434 (properties `((,mapping-property . #t)
1435 ,@(package-properties p)))))))
1438 ;; Return a variant of P with PROC applied to P and its explicit
1439 ;; dependencies, recursively. Memoize the transformations. Failing
1440 ;; to do that, we would build a huge object graph with lots of
1441 ;; duplicates, which in turns prevents us from benefiting from
1442 ;; memoization in 'package-derivation'.
1446 (location (package-location p))
1447 (build-system (if deep?
1448 (build-system-with-package-mapping
1449 (package-build-system p) rewrite)
1450 (package-build-system p)))
1451 (inputs (map rewrite (package-inputs p)))
1452 (native-inputs (map rewrite (package-native-inputs p)))
1453 (propagated-inputs (map rewrite (package-propagated-inputs p)))
1454 (replacement (and=> (package-replacement p) replace))
1455 (properties `((,mapping-property . #t)
1456 ,@(package-properties p)))))))))
1460 (define* (package-input-rewriting replacements
1461 #:optional (rewrite-name identity)
1463 "Return a procedure that, when passed a package, replaces its direct and
1464 indirect dependencies, including implicit inputs when DEEP? is true, according
1465 to REPLACEMENTS. REPLACEMENTS is a list of package pairs; the first element
1466 of each pair is the package to replace, and the second one is the replacement.
1468 Optionally, REWRITE-NAME is a one-argument procedure that takes the name of a
1469 package and returns its new name after rewrite."
1470 (define replacement-property
1471 ;; Property to tag right-hand sides in REPLACEMENTS.
1472 (gensym " package-replacement"))
1475 (if (assq-ref (package-properties p) replacement-property)
1477 (match (assq-ref replacements p)
1478 (#f (package/inherit p
1479 (name (rewrite-name (package-name p)))))
1481 (package/inherit new
1482 (properties `((,replacement-property . #t)
1483 ,@(package-properties new))))
1487 (or (assq-ref (package-properties p) replacement-property)
1488 (assq-ref replacements p)))
1490 (package-mapping rewrite cut?
1493 (define* (package-input-rewriting/spec replacements #:key (deep? #t))
1494 "Return a procedure that, given a package, applies the given REPLACEMENTS to
1495 all the package graph, including implicit inputs unless DEEP? is false.
1496 REPLACEMENTS is a list of spec/procedures pair; each spec is a package
1497 specification such as \"gcc\" or \"guile@2\", and each procedure takes a
1498 matching package and returns a replacement for that package."
1500 (fold (lambda (replacement table)
1503 (let-values (((name version)
1504 (package-name->name+version spec)))
1505 (vhash-cons name (list version proc) table)))))
1509 (define (find-replacement package)
1510 (vhash-fold* (lambda (item proc)
1516 (and (version-prefix? version
1517 (package-version package))
1520 (package-name package)
1523 (define replacement-property
1524 (gensym " package-replacement"))
1527 (if (assq-ref (package-properties p) replacement-property)
1529 (match (find-replacement p)
1532 (let ((new (proc p)))
1533 ;; Mark NEW as already processed.
1534 (package/inherit new
1535 (properties `((,replacement-property . #t)
1536 ,@(package-properties new)))))))))
1539 (or (assq-ref (package-properties p) replacement-property)
1540 (find-replacement p)))
1542 (package-mapping rewrite cut?
1547 ;;; Package derivations.
1550 (define (cache! cache package system thunk)
1551 "Memoize in CACHE the return values of THUNK as the derivation of PACKAGE on
1553 ;; FIXME: This memoization should be associated with the open store, because
1554 ;; otherwise it breaks when switching to a different store.
1555 (let ((result (thunk)))
1556 ;; Use `hashq-set!' instead of `hash-set!' because `hash' returns the
1557 ;; same value for all structs (as of Guile 2.0.6), and because pointer
1558 ;; equality is sufficient in practice.
1559 (hashq-set! cache package
1560 `((,system . ,result)
1561 ,@(or (hashq-ref cache package) '())))
1564 (define-syntax cached
1566 "Memoize the result of BODY for the arguments PACKAGE and SYSTEM.
1567 Return the cached result when available."
1568 ((_ (=> cache) package system body ...)
1569 (let ((thunk (lambda () body ...))
1571 (match (hashq-ref cache package)
1573 (match (assoc-ref alist key)
1574 (#f (cache! cache package key thunk))
1577 (cache! cache package key thunk)))))))
1579 (define* (expand-input package input system #:key target)
1580 "Expand INPUT, an input tuple, to a name/<gexp-input> tuple. PACKAGE is
1581 only used to provide contextual information in exceptions."
1582 (with-monad %store-monad
1584 ;; INPUT doesn't need to be lowered here because it'll be lowered down
1585 ;; the road in the gexp that refers to it. However, packages need to be
1586 ;; special-cased to pass #:graft? #f (only the "tip" of the package
1587 ;; graph needs to have #:graft? #t). Lowering them here also allows
1588 ;; 'bag->derivation' to delete non-eq? packages that lead to the same
1590 (((? string? name) (? package? package))
1591 (mlet %store-monad ((drv (if target
1592 (package->cross-derivation package
1595 (package->derivation package system
1597 (return (list name (gexp-input drv #:native? (not target))))))
1598 (((? string? name) (? package? package) (? string? output))
1599 (mlet %store-monad ((drv (if target
1600 (package->cross-derivation package
1603 (package->derivation package system
1605 (return (list name (gexp-input drv output #:native? (not target))))))
1607 (((? string? name) (? file-like? thing))
1608 (return (list name (gexp-input thing #:native? (not target)))))
1609 (((? string? name) (? file-like? thing) (? string? output))
1610 (return (list name (gexp-input thing output #:native? (not target)))))
1612 (and (? string?) (? file-exists? file)))
1613 ;; Add FILE to the store. When FILE is in the sub-directory of a
1614 ;; store path, it needs to be added anyway, so it can be used as a
1616 (return (list name (gexp-input (local-file file #:recursive? #t)
1617 #:native? (not target)))))
1619 (raise (condition (&package-input-error
1624 ;; 'eq?' cache mapping packages to system+target+graft?-dependent bags.
1625 ;; It significantly speeds things up when doing repeated calls to
1626 ;; 'package->bag' as is the case when building a profile.
1627 (make-weak-key-hash-table 200))
1629 (define* (package->bag package #:optional
1630 (system (%current-system))
1631 (target (%current-target-system))
1632 #:key (graft? (%graft?)))
1633 "Compile PACKAGE into a bag for SYSTEM, possibly cross-compiled to TARGET,
1635 (let ((package (or (and graft? (package-replacement package))
1637 (cached (=> %bag-cache)
1638 package (list system target)
1639 ;; Bind %CURRENT-SYSTEM and %CURRENT-TARGET-SYSTEM so that thunked
1640 ;; field values can refer to it.
1641 (parameterize ((%current-system system)
1642 (%current-target-system target))
1645 ($ <package> name version source build-system
1646 args inputs propagated-inputs native-inputs
1648 ;; Even though we prefer to use "@" to separate the package
1649 ;; name from the package version in various user-facing parts
1650 ;; of Guix, checkStoreName (in nix/libstore/store-api.cc)
1651 ;; prohibits the use of "@", so use "-" instead.
1652 (or (make-bag build-system (string-append name "-" version)
1656 #:inputs (append (inputs self)
1657 (propagated-inputs self))
1659 #:native-inputs (native-inputs self)
1660 #:arguments (args self))
1663 (&package-cross-build-system-error
1667 (package package))))))))))))
1669 (define %package-graft-cache
1670 ;; Cache mapping <package> records to <graft> records, for packages that
1671 ;; have a replacement.
1672 (allocate-store-connection-cache 'package-graft-cache))
1674 (define (input-graft system)
1675 "Return a monadic procedure that, given a package with a graft, returns a
1676 graft, and #f otherwise."
1677 (with-monad %store-monad
1679 (((? package? package) output)
1680 (let ((replacement (package-replacement package)))
1682 (mcached eq? (=> %package-graft-cache)
1683 (mlet %store-monad ((orig (package->derivation package system
1685 (new (package->derivation replacement system
1689 (origin-output output)
1691 (replacement-output output))))
1692 package output system)
1697 (define (input-cross-graft target system)
1698 "Same as 'input-graft', but for cross-compilation inputs."
1699 (with-monad %store-monad
1701 (((? package? package) output)
1702 (let ((replacement (package-replacement package)))
1704 (mlet %store-monad ((orig (package->cross-derivation package
1707 (new (package->cross-derivation replacement
1712 (origin-output output)
1714 (replacement-output output))))
1719 (define* (fold-bag-dependencies proc seed bag
1721 "Fold PROC over the packages BAG depends on. Each package is visited only
1722 once, in depth-first order. If NATIVE? is true, restrict to native
1723 dependencies; otherwise, restrict to target dependencies."
1724 (define bag-direct-inputs*
1727 (append (bag-build-inputs bag)
1728 (bag-target-inputs bag)
1729 (if (bag-target bag)
1731 (bag-host-inputs bag))))
1734 (let loop ((inputs (bag-direct-inputs* bag))
1736 (visited vlist-null))
1740 (((label (? package? head) . rest) . tail)
1741 (let ((output (match rest (() "out") ((output) output)))
1742 (outputs (vhash-foldq* cons '() head visited)))
1743 (if (member output outputs)
1744 (loop tail result visited)
1745 (let ((inputs (bag-direct-inputs* (package->bag head))))
1746 (loop (append inputs tail)
1747 (proc head output result)
1748 (vhash-consq head output visited))))))
1750 (loop tail result visited)))))
1752 (define* (bag-grafts bag)
1753 "Return the list of grafts potentially applicable to BAG. Potentially
1754 applicable grafts are collected by looking at direct or indirect dependencies
1755 of BAG that have a 'replacement'. Whether a graft is actually applicable
1756 depends on whether the outputs of BAG depend on the items the grafts refer
1757 to (see 'graft-derivation'.)"
1758 (define system (bag-system bag))
1759 (define target (bag-target bag))
1763 (let ((->graft (input-graft system)))
1764 (parameterize ((%current-system system)
1765 (%current-target-system #f))
1766 (fold-bag-dependencies (lambda (package output grafts)
1767 (mlet %store-monad ((grafts grafts))
1768 (>>= (->graft package output)
1770 (#f (return grafts))
1771 (graft (return (cons graft grafts)))))))
1777 (let ((->graft (input-cross-graft target system)))
1778 (parameterize ((%current-system system)
1779 (%current-target-system target))
1780 (fold-bag-dependencies
1781 (lambda (package output grafts)
1782 (mlet %store-monad ((grafts grafts))
1783 (>>= (->graft package output)
1785 (#f (return grafts))
1786 (graft (return (cons graft grafts)))))))
1792 ;; We can end up with several identical grafts if we stumble upon packages
1793 ;; that are not 'eq?' but map to the same derivation (this can happen when
1794 ;; using things like 'package-with-explicit-inputs'.) Hence the
1795 ;; 'delete-duplicates' call.
1796 (return (delete-duplicates
1797 (append native-grafts target-grafts)))))
1799 (define* (package-grafts* package
1800 #:optional (system (%current-system))
1802 "Return the list of grafts applicable to PACKAGE as built for SYSTEM and
1804 (let* ((package (or (package-replacement package) package))
1805 (bag (package->bag package system target)))
1808 (define package-grafts
1809 (store-lower package-grafts*))
1811 (define-inlinable (derivation=? drv1 drv2)
1812 "Return true if DRV1 and DRV2 are equal."
1814 (string=? (derivation-file-name drv1)
1815 (derivation-file-name drv2))))
1817 (define (input=? input1 input2)
1818 "Return true if INPUT1 and INPUT2 are equivalent."
1820 ((label1 obj1 . outputs1)
1822 ((label2 obj2 . outputs2)
1823 (and (string=? label1 label2)
1824 (equal? outputs1 outputs2)
1825 (or (and (derivation? obj1) (derivation? obj2)
1826 (derivation=? obj1 obj2))
1827 (equal? obj1 obj2))))))))
1829 (define* (bag->derivation bag #:optional context)
1830 "Return the derivation to build BAG for SYSTEM. Optionally, CONTEXT can be
1831 a package object describing the context in which the call occurs, for improved
1833 (if (bag-target bag)
1834 (bag->cross-derivation bag)
1835 (mlet* %store-monad ((system -> (bag-system bag))
1836 (inputs -> (bag-transitive-inputs bag))
1837 (input-drvs (mapm %store-monad
1838 (cut expand-input context <> system)
1840 (paths -> (delete-duplicates
1841 (append-map (match-lambda
1842 ((_ (? package? p) _ ...)
1843 (package-native-search-paths
1847 ;; It's possible that INPUTS contains packages that are not 'eq?' but
1848 ;; that lead to the same derivation. Delete those duplicates to avoid
1849 ;; issues down the road, such as duplicate entries in '%build-inputs'.
1850 (apply (bag-build bag) (bag-name bag)
1851 (delete-duplicates input-drvs input=?)
1852 #:search-paths paths
1853 #:outputs (bag-outputs bag) #:system system
1854 (bag-arguments bag)))))
1856 (define* (bag->cross-derivation bag #:optional context)
1857 "Return the derivation to build BAG, which is actually a cross build.
1858 Optionally, CONTEXT can be a package object denoting the context of the call.
1859 This is an internal procedure."
1860 (mlet* %store-monad ((system -> (bag-system bag))
1861 (target -> (bag-target bag))
1862 (host -> (bag-transitive-host-inputs bag))
1863 (host-drvs (mapm %store-monad
1864 (cut expand-input context <>
1865 system #:target target)
1867 (target* -> (bag-transitive-target-inputs bag))
1868 (target-drvs (mapm %store-monad
1869 (cut expand-input context <> system)
1871 (build -> (bag-transitive-build-inputs bag))
1872 (build-drvs (mapm %store-monad
1873 (cut expand-input context <> system)
1875 (all -> (append build target* host))
1876 (paths -> (delete-duplicates
1877 (append-map (match-lambda
1878 ((_ (? package? p) _ ...)
1879 (package-search-paths p))
1882 (npaths -> (delete-duplicates
1883 (append-map (match-lambda
1884 ((_ (? package? p) _ ...)
1885 (package-native-search-paths
1890 (apply (bag-build bag) (bag-name bag)
1891 #:build-inputs (delete-duplicates build-drvs input=?)
1892 #:host-inputs (delete-duplicates host-drvs input=?)
1893 #:target-inputs (delete-duplicates target-drvs input=?)
1894 #:search-paths paths
1895 #:native-search-paths npaths
1896 #:outputs (bag-outputs bag)
1897 #:system system #:target target
1898 (bag-arguments bag))))
1900 (define bag->derivation*
1901 (store-lower bag->derivation))
1903 (define graft-derivation*
1904 (store-lift graft-derivation))
1906 (define* (package->derivation package
1907 #:optional (system (%current-system))
1908 #:key (graft? (%graft?)))
1909 "Return the <derivation> object of PACKAGE for SYSTEM."
1911 ;; Compute the derivation and cache the result. Caching is important
1912 ;; because some derivations, such as the implicit inputs of the GNU build
1913 ;; system, will be queried many, many times in a row.
1914 (mcached (mlet* %store-monad ((bag -> (package->bag package system #f
1916 (drv (bag->derivation bag package)))
1918 (>>= (bag-grafts bag)
1923 (mlet %store-monad ((guile (package->derivation
1925 system #:graft? #f)))
1926 (graft-derivation* drv grafts
1930 package system #f graft?))
1932 (define* (package->cross-derivation package target
1933 #:optional (system (%current-system))
1934 #:key (graft? (%graft?)))
1935 "Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix
1936 system identifying string)."
1937 (mcached (mlet* %store-monad ((bag -> (package->bag package system target
1939 (drv (bag->derivation bag package)))
1941 (>>= (bag-grafts bag)
1946 (mlet %store-monad ((guile (package->derivation
1948 system #:graft? #f)))
1949 (graft-derivation* drv grafts
1953 package system target graft?))
1955 (define* (package-output store package
1956 #:optional (output "out") (system (%current-system)))
1957 "Return the output path of PACKAGE's OUTPUT for SYSTEM---where OUTPUT is the
1958 symbolic output name, such as \"out\". Note that this procedure calls
1959 `package-derivation', which is costly."
1960 (let ((drv (package-derivation store package system)))
1961 (derivation->output-path drv output)))
1965 ;;; Monadic interface.
1968 (define (set-guile-for-build guile)
1969 "This monadic procedure changes the Guile currently used to run the build
1970 code of derivations to GUILE, a package object."
1972 (let ((guile (package-derivation store guile)))
1973 (values (%guile-for-build guile) store))))
1975 (define* (package-file package
1978 system (output "out") target)
1979 "Return as a monadic value the absolute file name of FILE within the
1980 OUTPUT directory of PACKAGE. When FILE is omitted, return the name of the
1981 OUTPUT directory of PACKAGE. When TARGET is true, use it as a
1982 cross-compilation target triplet.
1984 Note that this procedure does _not_ build PACKAGE. Thus, the result might or
1985 might not designate an existing file. We recommend not using this procedure
1986 unless you know what you are doing."
1988 (define compute-derivation
1990 (cut package-cross-derivation <> <> target <>)
1991 package-derivation))
1993 (let* ((system (or system (%current-system)))
1994 (drv (compute-derivation store package system))
1995 (out (derivation->output-path drv output)))
1997 (string-append out "/" file)
2001 (define package-derivation
2002 (store-lower package->derivation))
2004 (define package-cross-derivation
2005 (store-lower package->cross-derivation))
2007 (define-gexp-compiler (package-compiler (package <package>) system target)
2008 ;; Compile PACKAGE to a derivation for SYSTEM, optionally cross-compiled for
2009 ;; TARGET. This is used when referring to a package from within a gexp.
2011 (package->cross-derivation package target system)
2012 (package->derivation package system)))
2014 (define* (origin->derivation origin
2015 #:optional (system (%current-system)))
2016 "Return the derivation corresponding to ORIGIN."
2018 (($ <origin> uri method hash name (= force ()) #f)
2019 ;; No patches, no snippet: this is a fixed-output derivation.
2021 (content-hash-algorithm hash)
2022 (content-hash-value hash)
2023 name #:system system))
2024 (($ <origin> uri method hash name (= force (patches ...)) snippet
2025 flags inputs (modules ...) guile-for-build)
2026 ;; Patches and/or a snippet.
2027 (mlet %store-monad ((source (method uri
2028 (content-hash-algorithm hash)
2029 (content-hash-value hash)
2030 name #:system system))
2031 (guile (package->derivation (or guile-for-build
2035 (patch-and-repack source patches
2041 #:guile-for-build guile)))))
2043 (define-gexp-compiler (origin-compiler (origin <origin>) system target)
2044 ;; Compile ORIGIN to a derivation for SYSTEM. This is used when referring
2045 ;; to an origin from within a gexp.
2046 (origin->derivation origin system))
2048 (define package-source-derivation ;somewhat deprecated
2049 (let ((lower (store-lower lower-object)))
2050 (lambda* (store source #:optional (system (%current-system)))
2051 "Return the derivation or file corresponding to SOURCE, which can be an
2052 a file name or any object handled by 'lower-object', such as an <origin>.
2053 When SOURCE is a file name, return either the interned file name (if SOURCE is
2054 outside of the store) or SOURCE itself (if SOURCE is already a store item.)"
2056 ((and (? string?) (? direct-store-path?) file)
2059 (add-to-store store (basename file) #t "sha256" file))
2061 (lower store source system))))))