;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014, 2015, 2017, 2018, 2019 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
-;;; Copyright © 2017, 2019, 2020 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2017, 2019, 2020, 2022 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2019 Marius Bakke <mbakke@fastmail.com>
+;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
;;;
;;; This file is part of GNU Guix.
;;;
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix packages)
+ #:use-module ((guix build utils) #:select (compressor tarball?
+ strip-store-file-name))
#:use-module (guix utils)
#:use-module (guix records)
#:use-module (guix store)
#:use-module (guix search-paths)
#:use-module (guix sets)
#:use-module (guix deprecation)
+ #:use-module ((guix diagnostics)
+ #:select (formatted-message define-with-syntax-properties))
+ #:autoload (guix licenses) (license?)
#:use-module (guix i18n)
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
#:use-module (srfi srfi-35)
#:use-module (rnrs bytevectors)
#:use-module (web uri)
+ #:autoload (texinfo) (texi-fragment->stexi)
#:re-export (%current-system
%current-target-system
search-path-specification) ;for convenience
deprecated-package
package-field-location
+ this-package-input
+ this-package-native-input
+
+ lookup-package-input
+ lookup-package-native-input
+ lookup-package-propagated-input
+ lookup-package-direct-input
+
+ prepend ;syntactic keyword
+ replace ;syntactic keyword
+ modify-inputs
+
package-direct-sources
package-transitive-sources
package-direct-inputs
transitive-input-references
+ %32bit-supported-systems
+ %64bit-supported-systems
%supported-systems
%hurd-systems
%cuirass-supported-systems
&package-error
package-error?
package-error-package
+ package-license-error?
+ package-error-invalid-license
&package-input-error
package-input-error?
package-error-invalid-input
bag-transitive-host-inputs
bag-transitive-build-inputs
bag-transitive-target-inputs
+ package-development-inputs
package-closure
default-guile
package->cross-derivation
origin->derivation))
+;; The 'source-module-closure' procedure ca. 1.2.0 did not recognize
+;; #:re-export-and-replace: <https://issues.guix.gnu.org/52694>.
+;; Work around it. The #:replace? argument is only supported by
+;; Guile 2.2.7 and later, work-around it if necessary to allow
+;; time-travel from 1.1.0, see <https://issues.guix.gnu.org/53765>.
+(let ((major (string->number (major-version))))
+ (if (or (>= major 3)
+ (and (= major 2)
+ (= (string->number (minor-version)) 2) ; there is no Guile 2.3.X
+ (>= (string->number (micro-version)) 7)))
+ (module-re-export! (current-module) '(delete) #:replace? #t)
+ (module-re-export! (current-module) '(delete))))
+
;;; Commentary:
;;;
;;; This module provides a high-level mechanism to define packages in a
(default '()) (delayed))
(snippet origin-snippet (default #f)) ; sexp or #f
- (patch-flags origin-patch-flags ; list of strings
- (default '("-p1")))
+ (patch-flags origin-patch-flags ; string-list gexp
+ (default %default-patch-flags))
;; Patching requires Guile, GNU Patch, and a few more. These two fields are
;; used to specify these dependencies when needed.
(set-record-type-printer! <origin> print-origin)
+(define %default-patch-flags
+ #~("-p1"))
+
(define (origin-actual-file-name origin)
"Return the file name of ORIGIN, either its 'file-name' field or the file
name of its URI."
#:guile-for-build guile)))
\f
+(define %32bit-supported-systems
+ ;; This is the list of 32-bit system types that are supported.
+ '("i686-linux" "armhf-linux" "i586-gnu" "powerpc-linux"))
+
+(define %64bit-supported-systems
+ ;; This is the list of 64-bit system types that are supported.
+ '("x86_64-linux" "mips64el-linux" "aarch64-linux" "powerpc64le-linux"
+ "riscv64-linux"))
+
(define %supported-systems
;; This is the list of system types that are supported. By default, we
;; expect all packages to build successfully here.
- '("x86_64-linux" "i686-linux" "armhf-linux" "aarch64-linux" "mips64el-linux" "i586-gnu"
- "powerpc64le-linux"))
+ (append %64bit-supported-systems %32bit-supported-systems))
(define %hurd-systems
;; The GNU/Hurd systems for which support is being developed.
;;
;; XXX: MIPS is unavailable in CI:
;; <https://lists.gnu.org/archive/html/guix-devel/2017-03/msg00790.html>.
- (fold delete %supported-systems '("mips64el-linux")))
+ (fold delete %supported-systems '("mips64el-linux" "powerpc-linux" "riscv64-linux")))
+
+(define-inlinable (sanitize-inputs inputs)
+ "Sanitize INPUTS by turning it into a list of name/package tuples if it's
+not already the case."
+ (cond ((null? inputs) inputs)
+ ((and (pair? (car inputs))
+ (string? (caar inputs)))
+ inputs)
+ (else (map add-input-label inputs))))
(define-syntax current-location-vector
(lambda (s)
(lambda (s) #,location)))
body ...))))))
+(define-syntax validate-texinfo
+ (let ((validate? (getenv "GUIX_UNINSTALLED")))
+ (define ensure-thread-safe-texinfo-parser!
+ ;; Work around <https://issues.guix.gnu.org/51264> for Guile <= 3.0.7.
+ (let ((patched? (or (> (string->number (major-version)) 3)
+ (> (string->number (minor-version)) 0)
+ (> (string->number (micro-version)) 7)))
+ (next-token-of/thread-safe
+ (lambda (pred port)
+ (let loop ((chars '()))
+ (match (read-char port)
+ ((? eof-object?)
+ (list->string (reverse! chars)))
+ (chr
+ (let ((chr* (pred chr)))
+ (if chr*
+ (loop (cons chr* chars))
+ (begin
+ (unread-char chr port)
+ (list->string (reverse! chars)))))))))))
+ (lambda ()
+ (unless patched?
+ (set! (@@ (texinfo) next-token-of) next-token-of/thread-safe)
+ (set! patched? #t)))))
+
+ (lambda (s)
+ "Raise a syntax error when passed a literal string that is not valid
+Texinfo. Otherwise, return the string."
+ (syntax-case s ()
+ ((_ str)
+ (string? (syntax->datum #'str))
+ (if validate?
+ (catch 'parser-error
+ (lambda ()
+ (ensure-thread-safe-texinfo-parser!)
+ (texi-fragment->stexi (syntax->datum #'str))
+ #'str)
+ (lambda _
+ (syntax-violation 'package "invalid Texinfo markup" #'str)))
+ #'str))
+ ((_ obj)
+ #'obj)))))
+
+(define-syntax valid-license-value?
+ (syntax-rules (list package-license)
+ "Return #t if the given value is a valid license field, #f otherwise."
+ ;; Arrange so that the answer can be given at macro-expansion time in the
+ ;; most common cases.
+ ((_ (list x ...))
+ (and (license? x) ...))
+ ((_ (package-license _))
+ #t)
+ ((_ obj)
+ (or (license? obj)
+ ;; Note: Avoid 'not' below due to <https://bugs.gnu.org/58217>.
+ (eq? #f obj) ;#f is considered valid
+ (let ((x obj))
+ (and (pair? x) (every license? x)))))))
+
+(define-with-syntax-properties (validate-license (value properties))
+ (unless (valid-license-value? value)
+ (raise
+ (make-compound-condition
+ (condition
+ (&error-location
+ (location (source-properties->location properties))))
+ (condition
+ (&package-license-error (package #f) (license value)))
+ (formatted-message (G_ "~s: invalid package license~%") value))))
+ value)
+
;; A package.
(define-record-type* <package>
package make-package
(name package-name) ; string
(version package-version) ; string
(source package-source) ; <origin> instance
- (build-system package-build-system) ; build system
+ (build-system package-build-system) ; <build-system> instance
(arguments package-arguments ; arguments for the build method
(default '()) (thunked))
(inputs package-inputs ; input packages or derivations
- (default '()) (thunked))
+ (default '()) (thunked)
+ (sanitize sanitize-inputs))
(propagated-inputs package-propagated-inputs ; same, but propagated
- (default '()) (thunked))
+ (default '()) (thunked)
+ (sanitize sanitize-inputs))
(native-inputs package-native-inputs ; native input packages/derivations
- (default '()) (thunked))
+ (default '()) (thunked)
+ (sanitize sanitize-inputs))
(outputs package-outputs ; list of strings
(default '("out")))
(replacement package-replacement ; package | #f
(default #f) (thunked) (innate))
- (synopsis package-synopsis) ; one-line description
- (description package-description) ; one or two paragraphs
- (license package-license)
+ (synopsis package-synopsis
+ (sanitize validate-texinfo)) ; one-line description
+ (description package-description
+ (sanitize validate-texinfo)) ; one or two paragraphs
+ (license package-license ; (list of) <license>
+ (sanitize validate-license))
(home-page package-home-page)
(supported-systems package-supported-systems ; list of strings
(default %supported-systems))
(default (current-definition-location))
(innate)))
+(define (add-input-label input)
+ "Add an input label to INPUT."
+ (match input
+ ((? package? package)
+ (list (package-name package) package))
+ (((? package? package) output) ;XXX: ugly?
+ (list (package-name package) package output))
+ ((? gexp-input?) ;XXX: misplaced because 'native?' field is ignored?
+ (let ((obj (gexp-input-thing input))
+ (output (gexp-input-output input)))
+ `(,(if (package? obj)
+ (package-name obj)
+ "_")
+ ,obj
+ ,@(if (string=? output "out") '() (list output)))))
+ (x
+ `("_" ,x))))
+
(set-record-type-printer! <package>
(lambda (package port)
(let ((loc (package-location package))
user interfaces, ignores."
(package
(inherit p)
+ (location (package-location p))
(properties `((hidden? . #t)
,@(package-properties p)))))
(assoc-ref (package-properties p) 'hidden?))
(define (package-superseded p)
- "Return the package the supersedes P, or #f if P is still current."
+ "Return the package that supersedes P, or #f if P is still current."
(assoc-ref (package-properties p) 'superseded))
(define (deprecated-package old-name p)
(define (package-field-location package field)
"Return the source code location of the definition of FIELD for PACKAGE, or
#f if it could not be determined."
- (define (goto port line column)
- (unless (and (= (port-column port) (- column 1))
- (= (port-line port) (- line 1)))
- (unless (eof-object? (read-char port))
- (goto port line column))))
-
(match (package-location package)
(($ <location> file line column)
(match (search-path %load-path file)
;; In general we want to keep relative file names for modules.
(call-with-input-file file-found
(lambda (port)
- (goto port line column)
+ (go-to-location port line column)
(match (read port)
(('package inits ...)
(let ((field (assoc field inits)))
#f)))
(_ #f)))
+(define-syntax-rule (this-package-input name)
+ "Return the input NAME of the package being defined--i.e., an input
+from the ‘inputs’ or ‘propagated-inputs’ field. Native inputs are not
+considered. If this input does not exist, return #f instead."
+ (or (lookup-package-input this-package name)
+ (lookup-package-propagated-input this-package name)))
+
+(define-syntax-rule (this-package-native-input name)
+ "Return the native package input NAME of the package being defined--i.e.,
+an input from the ‘native-inputs’ field. If this native input does not
+exist, return #f instead."
+ (lookup-package-native-input this-package name))
;; Error conditions.
package-error?
(package package-error-package))
+(define-condition-type &package-license-error &package-error
+ package-license-error?
+ (license package-error-invalid-license))
+
(define-condition-type &package-input-error &package-error
package-input-error?
(input package-error-invalid-input))
(let* ((canonical (module-ref (resolve-interface '(gnu packages base))
'canonical-package))
(ref (lambda (module var)
- (canonical
- (module-ref (resolve-interface module) var)))))
+ ;; Make sure 'canonical-package' is not influenced by
+ ;; '%current-target-system' since we're going to use the
+ ;; native package anyway.
+ (parameterize ((%current-target-system #f))
+ (canonical
+ (module-ref (resolve-interface module) var))))))
`(("tar" ,(ref '(gnu packages base) 'tar))
("xz" ,(ref '(gnu packages compression) 'xz))
("bzip2" ,(ref '(gnu packages compression) 'bzip2))
#:key
inputs
(snippet #f)
- (flags '("-p1"))
+ (flags %default-patch-flags)
(modules '())
(guile-for-build (%guile-for-build))
(system (%current-system)))
((package) package)
(#f #f)))))
- (define decompression-type
- (cond ((string-suffix? "gz" source-file-name) "gzip")
- ((string-suffix? "Z" source-file-name) "gzip")
- ((string-suffix? "bz2" source-file-name) "bzip2")
- ((string-suffix? "lz" source-file-name) "lzip")
- ((string-suffix? "zip" source-file-name) "unzip")
- (else "xz")))
-
- (define original-file-name
- ;; Remove the store prefix plus the slash, hash, and hyphen.
- (let* ((sans (string-drop source-file-name
- (+ (string-length (%store-prefix)) 1)))
- (dash (string-index sans #\-)))
- (string-drop sans (+ 1 dash))))
+ (define original-file-name (strip-store-file-name source-file-name))
(define (numeric-extension? file-name)
;; Return true if FILE-NAME ends with digits.
(define (tarxz-name file-name)
;; Return a '.tar.xz' file name based on FILE-NAME.
- (let ((base (cond ((numeric-extension? file-name)
- original-file-name)
- ((checkout? file-name)
- (string-drop-right file-name 9))
- (else (file-sans-extension file-name)))))
+ (let ((base (if (numeric-extension? file-name)
+ original-file-name
+ (file-sans-extension file-name))))
(string-append base
(if (equal? (file-extension base) "tar")
".xz"
(define instantiate-patch
(match-lambda
((? string? patch) ;deprecated
- (interned-file patch #:recursive? #t))
+ (local-file patch #:recursive? #t))
((? struct? patch) ;origin, local-file, etc.
- (lower-object patch system))))
-
- (mlet %store-monad ((tar -> (lookup-input "tar"))
- (xz -> (lookup-input "xz"))
- (patch -> (lookup-input "patch"))
- (locales -> (lookup-input "locales"))
- (decomp -> (lookup-input decompression-type))
- (patches (sequence %store-monad
- (map instantiate-patch patches))))
+ patch)))
+
+ (let ((tar (lookup-input "tar"))
+ (gzip (lookup-input "gzip"))
+ (bzip2 (lookup-input "bzip2"))
+ (lzip (lookup-input "lzip"))
+ (xz (lookup-input "xz"))
+ (patch (lookup-input "patch"))
+ (locales (lookup-input "locales"))
+ (comp (and=> (compressor source-file-name) lookup-input))
+ (patches (map instantiate-patch patches)))
(define build
(with-imported-modules '((guix build utils))
#~(begin
(use-modules (ice-9 ftw)
+ (ice-9 match)
+ (ice-9 regex)
(srfi srfi-1)
+ (srfi srfi-26)
(guix build utils))
;; The --sort option was added to GNU tar in version 1.28, released
(lambda (name)
(not (member name '("." "..")))))))
- ;; Encoding/decoding errors shouldn't be silent.
- (fluid-set! %default-port-conversion-strategy 'error)
-
- (when #+locales
- ;; First of all, install a UTF-8 locale so that UTF-8 file names
- ;; are correctly interpreted. During bootstrap, LOCALES is #f.
- (setenv "LOCPATH"
- (string-append #+locales "/lib/locale/"
- #+(and locales
- (version-major+minor
- (package-version locales)))))
- (setlocale LC_ALL "en_US.utf8"))
-
- (setenv "PATH" (string-append #+xz "/bin" ":"
- #+decomp "/bin"))
-
- ;; SOURCE may be either a directory or a tarball.
- (if (file-is-directory? #+source)
- (let* ((store (%store-directory))
- (len (+ 1 (string-length store)))
- (base (string-drop #+source len))
- (dash (string-index base #\-))
- (directory (string-drop base (+ 1 dash))))
- (mkdir directory)
- (copy-recursively #+source directory))
- #+(if (string=? decompression-type "unzip")
- #~(invoke "unzip" #+source)
- #~(invoke (string-append #+tar "/bin/tar")
- "xvf" #+source)))
-
- (let ((directory (first-file ".")))
- (format (current-error-port)
- "source is under '~a'~%" directory)
- (chdir directory)
-
- (for-each apply-patch '#+patches)
-
- (let ((result #+(if snippet
- #~(let ((module (make-fresh-user-module)))
- (module-use-interfaces!
- module
- (map resolve-interface '#+modules))
- ((@ (system base compile) compile)
- '#+snippet
- #:to 'value
- #:opts %auto-compilation-options
- #:env module))
- #~#t)))
- ;; Issue a warning unless the result is #t.
- (unless (eqv? result #t)
- (format (current-error-port) "\
-## WARNING: the snippet returned `~s'. Return values other than #t
-## are deprecated. Please migrate this package so that its snippet
-## reports errors by raising an exception, and otherwise returns #t.~%"
- result))
- (unless result
- (error "snippet returned false")))
-
- (chdir "..")
-
+ (define (repack directory output)
+ ;; Write to OUTPUT a compressed tarball containing DIRECTORY.
(unless tar-supports-sort?
(call-with-output-file ".file_list"
(lambda (port)
(find-files directory
#:directories? #t
#:fail-on-error? #t)))))
- (apply invoke
- (string-append #+tar "/bin/tar")
- "cvfa" #$output
+
+ (apply invoke #+(file-append tar "/bin/tar")
+ "cvfa" output
;; Avoid non-determinism in the archive. Set the mtime
;; to 1 as is the case in the store (software like gzip
;; behaves differently when it stumbles upon mtime = 0).
"--mtime=@1"
- "--owner=root:0"
- "--group=root:0"
+ "--owner=root:0" "--group=root:0"
(if tar-supports-sort?
- `("--sort=name"
- ,directory)
+ `("--sort=name" ,directory)
'("--no-recursion"
- "--files-from=.file_list")))))))
+ "--files-from=.file_list"))))
+
+ ;; Encoding/decoding errors shouldn't be silent.
+ (fluid-set! %default-port-conversion-strategy 'error)
- (let ((name (tarxz-name original-file-name)))
+ (when #+locales
+ ;; First of all, install a UTF-8 locale so that UTF-8 file names
+ ;; are correctly interpreted. During bootstrap, LOCALES is #f.
+ (setenv "LOCPATH"
+ (string-append #+locales "/lib/locale/"
+ #+(and locales
+ (version-major+minor
+ (package-version locales)))))
+ (setlocale LC_ALL "en_US.utf8"))
+
+ (setenv "PATH"
+ (string-append #+xz "/bin"
+ (if #+comp
+ (string-append ":" #+comp "/bin")
+ "")))
+
+ (setenv "XZ_DEFAULTS" (string-join (%xz-parallel-args)))
+
+ ;; SOURCE may be either a directory, a tarball or a simple file.
+ (let ((name (strip-store-file-name #+source))
+ (command (and=> #+comp (cut string-append <> "/bin/"
+ (compressor #+source)))))
+ (if (file-is-directory? #+source)
+ (copy-recursively #+source name)
+ (cond
+ ((tarball? #+source)
+ (invoke (string-append #+tar "/bin/tar") "xvf" #+source))
+ ((and=> (compressor #+source) (cut string= "unzip" <>))
+ ;; Note: Referring to the store unzip here (#+unzip)
+ ;; would introduce a cycle.
+ (invoke "unzip" #+source))
+ (else
+ (copy-file #+source name)
+ (when command
+ (invoke command "--decompress" name))))))
+
+ (let* ((file (first-file "."))
+ (directory (if (file-is-directory? file)
+ file
+ ".")))
+ (format (current-error-port) "source is at '~a'~%" file)
+
+ (with-directory-excursion directory
+
+ (for-each apply-patch '#+patches)
+
+ #+(if snippet
+ #~(let ((module (make-fresh-user-module)))
+ (module-use-interfaces!
+ module
+ (map resolve-interface '#+modules))
+ ((@ (system base compile) compile)
+ '#+(if (pair? snippet)
+ (sexp->gexp snippet)
+ snippet)
+ #:to 'value
+ #:opts %auto-compilation-options
+ #:env module))
+ #~#t))
+
+ ;; If SOURCE is a directory (such as a checkout), return a
+ ;; directory. Otherwise create a tarball.
+ (cond
+ ((file-is-directory? #+source)
+ (copy-recursively directory #$output
+ #:log (%make-void-port "w")))
+ ((or #+comp (tarball? #+source))
+ (repack directory #$output))
+ (else ;single uncompressed file
+ (copy-file file #$output)))))))
+
+ (let ((name (if (or (checkout? original-file-name)
+ (not (compressor original-file-name)))
+ original-file-name
+ (tarxz-name original-file-name))))
(gexp->derivation name build
#:graft? #f
#:system system
((input rest ...)
(loop rest (cons input result) propagated first? seen)))))
+(define (lookup-input inputs name)
+ "Lookup NAME among INPUTS, an input list."
+ ;; Note: Currently INPUTS is assumed to be an input list that contains input
+ ;; labels. In the future, input labels will be gone and this procedure will
+ ;; check package names.
+ (match (assoc-ref inputs name)
+ ((obj) obj)
+ ((obj _) obj)
+ (#f #f)))
+
+(define (lookup-package-input package name)
+ "Look up NAME among PACKAGE's inputs. Return it if found, #f otherwise."
+ (lookup-input (package-inputs package) name))
+
+(define (lookup-package-native-input package name)
+ "Look up NAME among PACKAGE's native inputs. Return it if found, #f
+otherwise."
+ (lookup-input (package-native-inputs package) name))
+
+(define (lookup-package-propagated-input package name)
+ "Look up NAME among PACKAGE's propagated inputs. Return it if found, #f
+otherwise."
+ (lookup-input (package-propagated-inputs package) name))
+
+(define (lookup-package-direct-input package name)
+ "Look up NAME among PACKAGE's direct inputs. Return it if found, #f
+otherwise."
+ (lookup-input (package-direct-inputs package) name))
+
+(define (replace-input name replacement inputs)
+ "Replace input NAME by REPLACEMENT within INPUTS."
+ (map (lambda (input)
+ (match input
+ (((? string? label) _ . outputs)
+ (if (string=? label name)
+ (match replacement ;does REPLACEMENT specify an output?
+ ((_ _) (cons label replacement))
+ (_ (cons* label replacement outputs)))
+ input))))
+ inputs))
+
+(define-syntax prepend
+ (lambda (s)
+ (syntax-violation 'prepend
+ "'prepend' may only be used within 'modify-inputs'"
+ s)))
+
+(define-syntax replace
+ (lambda (s)
+ (syntax-violation 'replace
+ "'replace' may only be used within 'modify-inputs'"
+ s)))
+
+(define-syntax modify-inputs
+ (syntax-rules (delete prepend append replace)
+ "Modify the given package inputs, as returned by 'package-inputs' & co.,
+according to the given clauses. The example below removes the GMP and ACL
+inputs of Coreutils and adds libcap:
+
+ (modify-inputs (package-inputs coreutils)
+ (delete \"gmp\" \"acl\")
+ (append libcap))
+
+Other types of clauses include 'prepend' and 'replace'.
+
+The first argument must be a labeled input list; the result is also a labeled
+input list."
+ ;; Note: This macro hides the fact that INPUTS, as returned by
+ ;; 'package-inputs' & co., is actually an alist with labels. Eventually,
+ ;; it will operate on list of inputs without labels.
+ ((_ inputs (delete name) clauses ...)
+ (modify-inputs (alist-delete name inputs)
+ clauses ...))
+ ((_ inputs (delete names ...) clauses ...)
+ (modify-inputs (fold alist-delete inputs (list names ...))
+ clauses ...))
+ ((_ inputs (prepend lst ...) clauses ...)
+ (modify-inputs (append (map add-input-label (list lst ...)) inputs)
+ clauses ...))
+ ((_ inputs (append lst ...) clauses ...)
+ (modify-inputs (append inputs (map add-input-label (list lst ...)))
+ clauses ...))
+ ((_ inputs (replace name replacement) clauses ...)
+ (modify-inputs (replace-input name replacement inputs)
+ clauses ...))
+ ((_ inputs)
+ inputs)))
+
(define (package-direct-sources package)
"Return all source origins associated with PACKAGE; including origins in
PACKAGE's inputs."
(define package-transitive-supported-systems
(let ()
- (define supported-systems
- (mlambda (package system)
- (parameterize ((%current-system system))
- (fold (lambda (input systems)
- (match input
- ((label (? package? package) . _)
- (lset-intersection string=? systems
- (supported-systems package system)))
- (_
- systems)))
- (package-supported-systems package)
- (bag-direct-inputs (package->bag package))))))
+ (define (supported-systems-procedure system)
+ (define supported-systems
+ (mlambdaq (package)
+ (parameterize ((%current-system system))
+ (fold (lambda (input systems)
+ (match input
+ ((label (? package? package) . _)
+ (lset-intersection string=? systems
+ (supported-systems package)))
+ (_
+ systems)))
+ (package-supported-systems package)
+ (bag-direct-inputs (package->bag package system #f))))))
+
+ supported-systems)
+
+ (define procs
+ ;; Map system strings to one-argument procedures. This allows these
+ ;; procedures to have fast 'eq?' memoization on their argument.
+ (make-hash-table))
(lambda* (package #:optional (system (%current-system)))
"Return the intersection of the systems supported by PACKAGE and those
supported by its dependencies."
- (supported-systems package system))))
+ (match (hash-ref procs system)
+ (#f
+ (hash-set! procs system (supported-systems-procedure system))
+ (package-transitive-supported-systems package system))
+ (proc
+ (proc package))))))
(define* (supported-package? package #:optional (system (%current-system)))
"Return true if PACKAGE is supported on SYSTEM--i.e., if PACKAGE and all its
(%current-system (bag-system bag)))
(transitive-inputs (bag-target-inputs bag))))
+(define* (package-development-inputs package
+ #:optional (system (%current-system))
+ #:key target)
+ "Return the list of inputs required by PACKAGE for development purposes on
+SYSTEM. When TARGET is true, return the inputs needed to cross-compile
+PACKAGE from SYSTEM to TRIPLET, where TRIPLET is a triplet such as
+\"aarch64-linux-gnu\"."
+ (bag-transitive-inputs (package->bag package system target)))
+
(define* (package-closure packages #:key (system (%current-system)))
"Return the closure of PACKAGES on SYSTEM--i.e., PACKAGES and the list of
packages they depend on, recursively."
;;; Package derivations.
;;;
-(define %derivation-cache
- ;; Package to derivation-path mapping.
- (make-weak-key-hash-table 100))
-
(define (cache! cache package system thunk)
"Memoize in CACHE the return values of THUNK as the derivation of PACKAGE on
SYSTEM."
(#f (cache! cache package key thunk))
(value value)))
(#f
- (cache! cache package key thunk)))))
- ((_ package system body ...)
- (cached (=> %derivation-cache) package system body ...))))
-
-(define* (expand-input store package input system #:optional cross-system)
- "Expand INPUT, an input tuple, such that it contains only references to
-derivation paths or store paths. PACKAGE is only used to provide contextual
-information in exceptions."
- (define (intern file)
- ;; Add FILE to the store. Set the `recursive?' bit to #t, so that
- ;; file permissions are preserved.
- (add-to-store store (basename file) #t "sha256" file))
-
- (define derivation
- (if cross-system
- (cut package-cross-derivation store <> cross-system system
- #:graft? #f)
- (cut package-derivation store <> system #:graft? #f)))
+ (cache! cache package key thunk)))))))
- (match input
- (((? string? name) (? package? package))
- (list name (derivation package)))
- (((? string? name) (? package? package)
- (? string? sub-drv))
- (list name (derivation package)
- sub-drv))
- (((? string? name)
- (and (? string?) (? derivation-path?) drv))
- (list name drv))
- (((? string? name)
- (and (? string?) (? file-exists? file)))
- ;; Add FILE to the store. When FILE is in the sub-directory of a
- ;; store path, it needs to be added anyway, so it can be used as a
- ;; source.
- (list name (intern file)))
- (((? string? name) (? struct? source))
- ;; 'package-source-derivation' calls 'lower-object', which can throw
- ;; '&gexp-input-error'. However '&gexp-input-error' lacks source
- ;; location info, so we catch and rethrow here (XXX: not optimal
- ;; performance-wise).
- (guard (c ((gexp-input-error? c)
- (raise (condition
- (&package-input-error
- (package package)
- (input (gexp-error-invalid-input c)))))))
- (list name (package-source-derivation store source system))))
- (x
- (raise (condition (&package-input-error
- (package package)
- (input x)))))))
+(define* (expand-input package input system #:key target)
+ "Expand INPUT, an input tuple, to a name/<gexp-input> tuple. PACKAGE is
+only used to provide contextual information in exceptions."
+ (with-monad %store-monad
+ (match input
+ ;; INPUT doesn't need to be lowered here because it'll be lowered down
+ ;; the road in the gexp that refers to it. However, packages need to be
+ ;; special-cased to pass #:graft? #f (only the "tip" of the package
+ ;; graph needs to have #:graft? #t). Lowering them here also allows
+ ;; 'bag->derivation' to delete non-eq? packages that lead to the same
+ ;; derivation.
+ (((? string? name) (? package? package))
+ (mlet %store-monad ((drv (if target
+ (package->cross-derivation package
+ target system
+ #:graft? #f)
+ (package->derivation package system
+ #:graft? #f))))
+ (return (list name (gexp-input drv #:native? (not target))))))
+ (((? string? name) (? package? package) (? string? output))
+ (mlet %store-monad ((drv (if target
+ (package->cross-derivation package
+ target system
+ #:graft? #f)
+ (package->derivation package system
+ #:graft? #f))))
+ (return (list name (gexp-input drv output #:native? (not target))))))
+
+ (((? string? name) (? file-like? thing))
+ (return (list name (gexp-input thing #:native? (not target)))))
+ (((? string? name) (? file-like? thing) (? string? output))
+ (return (list name (gexp-input thing output #:native? (not target)))))
+ (((? string? name)
+ (and (? string?) (? file-exists? file)))
+ ;; Add FILE to the store. When FILE is in the sub-directory of a
+ ;; store path, it needs to be added anyway, so it can be used as a
+ ;; source.
+ (return (list name (gexp-input (local-file file #:recursive? #t)
+ #:native? (not target)))))
+ (x
+ (raise (condition (&package-input-error
+ (package package)
+ (input x))))))))
(define %bag-cache
;; 'eq?' cache mapping packages to system+target+graft?-dependent bags.
(&package-error
(package package))))))))))))
-(define %graft-cache
- ;; 'eq?' cache mapping package objects to a graft corresponding to their
- ;; replacement package.
- (make-weak-key-hash-table 200))
+(define %package-graft-cache
+ ;; Cache mapping <package> records to <graft> records, for packages that
+ ;; have a replacement.
+ (allocate-store-connection-cache 'package-graft-cache))
+
+(define (input-graft system)
+ "Return a monadic procedure that, given a package with a graft, returns a
+graft, and #f otherwise."
+ (with-monad %store-monad
+ (match-lambda*
+ (((? package? package) output)
+ (let ((replacement (package-replacement package)))
+ (if replacement
+ (mcached eq? (=> %package-graft-cache)
+ (mlet %store-monad ((orig (package->derivation package system
+ #:graft? #f))
+ (new (package->derivation replacement system
+ #:graft? #t)))
+ (return (graft
+ (origin orig)
+ (origin-output output)
+ (replacement new)
+ (replacement-output output))))
+ package output system)
+ (return #f))))
+ (_
+ (return #f)))))
-(define (input-graft store system)
- "Return a procedure that, given a package with a replacement and an output name,
-returns a graft, and #f otherwise."
- (match-lambda*
- (((? package? package) output)
- (let ((replacement (package-replacement package)))
- (and replacement
- (cached (=> %graft-cache) package (cons output system)
- (let ((orig (package-derivation store package system
- #:graft? #f))
- (new (package-derivation store replacement system
- #:graft? #t)))
- (graft
- (origin orig)
- (origin-output output)
- (replacement new)
- (replacement-output output)))))))))
-
-(define (input-cross-graft store target system)
+(define (input-cross-graft target system)
"Same as 'input-graft', but for cross-compilation inputs."
- (match-lambda*
- (((? package? package) output)
- (let ((replacement (package-replacement package)))
- (and replacement
- (let ((orig (package-cross-derivation store package target system
- #:graft? #f))
- (new (package-cross-derivation store replacement
- target system
- #:graft? #t)))
- (graft
- (origin orig)
- (origin-output output)
- (replacement new)
- (replacement-output output))))))))
+ (with-monad %store-monad
+ (match-lambda*
+ (((? package? package) output)
+ (let ((replacement (package-replacement package)))
+ (if replacement
+ (mlet %store-monad ((orig (package->cross-derivation package
+ target system
+ #:graft? #f))
+ (new (package->cross-derivation replacement
+ target system
+ #:graft? #t)))
+ (return (graft
+ (origin orig)
+ (origin-output output)
+ (replacement new)
+ (replacement-output output))))
+ (return #f))))
+ (_
+ (return #f)))))
(define* (fold-bag-dependencies proc seed bag
#:key (native? #t))
((head . tail)
(loop tail result visited)))))
-(define* (bag-grafts store bag)
+(define* (bag-grafts bag)
"Return the list of grafts potentially applicable to BAG. Potentially
applicable grafts are collected by looking at direct or indirect dependencies
of BAG that have a 'replacement'. Whether a graft is actually applicable
(define system (bag-system bag))
(define target (bag-target bag))
- (define native-grafts
- (let ((->graft (input-graft store system)))
- (parameterize ((%current-system system)
- (%current-target-system #f))
- (fold-bag-dependencies (lambda (package output grafts)
- (match (->graft package output)
- (#f grafts)
- (graft (cons graft grafts))))
- '()
- bag))))
-
- (define target-grafts
- (if target
- (let ((->graft (input-cross-graft store target system)))
+ (mlet %store-monad
+ ((native-grafts
+ (let ((->graft (input-graft system)))
(parameterize ((%current-system system)
- (%current-target-system target))
+ (%current-target-system #f))
(fold-bag-dependencies (lambda (package output grafts)
- (match (->graft package output)
- (#f grafts)
- (graft (cons graft grafts))))
- '()
- bag
- #:native? #f)))
- '()))
-
- ;; We can end up with several identical grafts if we stumble upon packages
- ;; that are not 'eq?' but map to the same derivation (this can happen when
- ;; using things like 'package-with-explicit-inputs'.) Hence the
- ;; 'delete-duplicates' call.
- (delete-duplicates
- (append native-grafts target-grafts)))
-
-(define* (package-grafts store package
- #:optional (system (%current-system))
- #:key target)
+ (mlet %store-monad ((grafts grafts))
+ (>>= (->graft package output)
+ (match-lambda
+ (#f (return grafts))
+ (graft (return (cons graft grafts)))))))
+ (return '())
+ bag))))
+
+ (target-grafts
+ (if target
+ (let ((->graft (input-cross-graft target system)))
+ (parameterize ((%current-system system)
+ (%current-target-system target))
+ (fold-bag-dependencies
+ (lambda (package output grafts)
+ (mlet %store-monad ((grafts grafts))
+ (>>= (->graft package output)
+ (match-lambda
+ (#f (return grafts))
+ (graft (return (cons graft grafts)))))))
+ (return '())
+ bag
+ #:native? #f)))
+ (return '()))))
+
+ ;; We can end up with several identical grafts if we stumble upon packages
+ ;; that are not 'eq?' but map to the same derivation (this can happen when
+ ;; using things like 'package-with-explicit-inputs'.) Hence the
+ ;; 'delete-duplicates' call.
+ (return (delete-duplicates
+ (append native-grafts target-grafts)))))
+
+(define* (package-grafts* package
+ #:optional (system (%current-system))
+ #:key target)
"Return the list of grafts applicable to PACKAGE as built for SYSTEM and
TARGET."
(let* ((package (or (package-replacement package) package))
(bag (package->bag package system target)))
- (bag-grafts store bag)))
-
-(define* (bag->derivation store bag
- #:optional context)
+ (bag-grafts bag)))
+
+(define package-grafts
+ (store-lower package-grafts*))
+
+(define-inlinable (derivation=? drv1 drv2)
+ "Return true if DRV1 and DRV2 are equal."
+ (or (eq? drv1 drv2)
+ (string=? (derivation-file-name drv1)
+ (derivation-file-name drv2))))
+
+(define (input=? input1 input2)
+ "Return true if INPUT1 and INPUT2 are equivalent."
+ (match input1
+ ((label1 obj1 . outputs1)
+ (match input2
+ ((label2 obj2 . outputs2)
+ (and (string=? label1 label2)
+ (equal? outputs1 outputs2)
+ (or (and (derivation? obj1) (derivation? obj2)
+ (derivation=? obj1 obj2))
+ (equal? obj1 obj2))))))))
+
+(define* (bag->derivation bag #:optional context)
"Return the derivation to build BAG for SYSTEM. Optionally, CONTEXT can be
a package object describing the context in which the call occurs, for improved
error reporting."
(if (bag-target bag)
- (bag->cross-derivation store bag)
- (let* ((system (bag-system bag))
- (inputs (bag-transitive-inputs bag))
- (input-drvs (map (cut expand-input store context <> system)
- inputs))
- (paths (delete-duplicates
- (append-map (match-lambda
- ((_ (? package? p) _ ...)
- (package-native-search-paths
- p))
- (_ '()))
- inputs))))
-
- (apply (bag-build bag)
- store (bag-name bag) input-drvs
+ (bag->cross-derivation bag)
+ (mlet* %store-monad ((system -> (bag-system bag))
+ (inputs -> (bag-transitive-inputs bag))
+ (input-drvs (mapm %store-monad
+ (cut expand-input context <> system)
+ inputs))
+ (paths -> (delete-duplicates
+ (append-map (match-lambda
+ ((_ (? package? p) _ ...)
+ (package-native-search-paths
+ p))
+ (_ '()))
+ inputs))))
+ ;; It's possible that INPUTS contains packages that are not 'eq?' but
+ ;; that lead to the same derivation. Delete those duplicates to avoid
+ ;; issues down the road, such as duplicate entries in '%build-inputs'.
+ (apply (bag-build bag) (bag-name bag)
+ (delete-duplicates input-drvs input=?)
#:search-paths paths
#:outputs (bag-outputs bag) #:system system
(bag-arguments bag)))))
-(define* (bag->cross-derivation store bag
- #:optional context)
+(define* (bag->cross-derivation bag #:optional context)
"Return the derivation to build BAG, which is actually a cross build.
Optionally, CONTEXT can be a package object denoting the context of the call.
This is an internal procedure."
- (let* ((system (bag-system bag))
- (target (bag-target bag))
- (host (bag-transitive-host-inputs bag))
- (host-drvs (map (cut expand-input store context <> system target)
- host))
- (target* (bag-transitive-target-inputs bag))
- (target-drvs (map (cut expand-input store context <> system)
- target*))
- (build (bag-transitive-build-inputs bag))
- (build-drvs (map (cut expand-input store context <> system)
- build))
- (all (append build target* host))
- (paths (delete-duplicates
- (append-map (match-lambda
- ((_ (? package? p) _ ...)
- (package-search-paths p))
- (_ '()))
- all)))
- (npaths (delete-duplicates
- (append-map (match-lambda
- ((_ (? package? p) _ ...)
- (package-native-search-paths
- p))
- (_ '()))
- all))))
-
- (apply (bag-build bag)
- store (bag-name bag)
- #:native-drvs build-drvs
- #:target-drvs (append host-drvs target-drvs)
+ (mlet* %store-monad ((system -> (bag-system bag))
+ (target -> (bag-target bag))
+ (host -> (bag-transitive-host-inputs bag))
+ (host-drvs (mapm %store-monad
+ (cut expand-input context <>
+ system #:target target)
+ host))
+ (target* -> (bag-transitive-target-inputs bag))
+ (target-drvs (mapm %store-monad
+ (cut expand-input context <> system)
+ target*))
+ (build -> (bag-transitive-build-inputs bag))
+ (build-drvs (mapm %store-monad
+ (cut expand-input context <> system)
+ build))
+ (all -> (append build target* host))
+ (paths -> (delete-duplicates
+ (append-map (match-lambda
+ ((_ (? package? p) _ ...)
+ (package-search-paths p))
+ (_ '()))
+ all)))
+ (npaths -> (delete-duplicates
+ (append-map (match-lambda
+ ((_ (? package? p) _ ...)
+ (package-native-search-paths
+ p))
+ (_ '()))
+ all))))
+
+ (apply (bag-build bag) (bag-name bag)
+ #:build-inputs (delete-duplicates build-drvs input=?)
+ #:host-inputs (delete-duplicates host-drvs input=?)
+ #:target-inputs (delete-duplicates target-drvs input=?)
#:search-paths paths
#:native-search-paths npaths
#:outputs (bag-outputs bag)
#:system system #:target target
(bag-arguments bag))))
-(define* (package-derivation store package
- #:optional (system (%current-system))
- #:key (graft? (%graft?)))
+(define bag->derivation*
+ (store-lower bag->derivation))
+
+(define graft-derivation*
+ (store-lift graft-derivation))
+
+(define* (package->derivation package
+ #:optional (system (%current-system))
+ #:key (graft? (%graft?)))
"Return the <derivation> object of PACKAGE for SYSTEM."
;; Compute the derivation and cache the result. Caching is important
;; because some derivations, such as the implicit inputs of the GNU build
;; system, will be queried many, many times in a row.
- (cached package (cons system graft?)
- (let* ((bag (package->bag package system #f #:graft? graft?))
- (drv (bag->derivation store bag package)))
- (if graft?
- (match (bag-grafts store bag)
- (()
- drv)
- (grafts
- (let ((guile (package-derivation store (guile-for-grafts)
- system #:graft? #f)))
- ;; TODO: As an optimization, we can simply graft the tip
- ;; of the derivation graph since 'graft-derivation'
- ;; recurses anyway.
- (graft-derivation store drv grafts
- #:system system
- #:guile guile))))
- drv))))
-
-(define* (package-cross-derivation store package target
- #:optional (system (%current-system))
- #:key (graft? (%graft?)))
+ (mcached (mlet* %store-monad ((bag -> (package->bag package system #f
+ #:graft? graft?))
+ (drv (bag->derivation bag package)))
+ (if graft?
+ (>>= (bag-grafts bag)
+ (match-lambda
+ (()
+ (return drv))
+ (grafts
+ (mlet %store-monad ((guile (package->derivation
+ (guile-for-grafts)
+ system #:graft? #f)))
+ (graft-derivation* drv grafts
+ #:system system
+ #:guile guile)))))
+ (return drv)))
+ package system #f graft?))
+
+(define* (package->cross-derivation package target
+ #:optional (system (%current-system))
+ #:key (graft? (%graft?)))
"Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix
system identifying string)."
- (cached package (list system target graft?)
- (let* ((bag (package->bag package system target #:graft? graft?))
- (drv (bag->derivation store bag package)))
- (if graft?
- (match (bag-grafts store bag)
- (()
- drv)
- (grafts
- (graft-derivation store drv grafts
- #:system system
- #:guile
- (package-derivation store (guile-for-grafts)
- system #:graft? #f))))
- drv))))
+ (mcached (mlet* %store-monad ((bag -> (package->bag package system target
+ #:graft? graft?))
+ (drv (bag->derivation bag package)))
+ (if graft?
+ (>>= (bag-grafts bag)
+ (match-lambda
+ (()
+ (return drv))
+ (grafts
+ (mlet %store-monad ((guile (package->derivation
+ (guile-for-grafts)
+ system #:graft? #f)))
+ (graft-derivation* drv grafts
+ #:system system
+ #:guile guile)))))
+ (return drv)))
+ package system target graft?))
(define* (package-output store package
#:optional (output "out") (system (%current-system)))
out)
store))))
-(define package->derivation
- (store-lift package-derivation))
+(define package-derivation
+ (store-lower package->derivation))
-(define package->cross-derivation
- (store-lift package-cross-derivation))
+(define package-cross-derivation
+ (store-lower package->cross-derivation))
(define-gexp-compiler (package-compiler (package <package>) system target)
;; Compile PACKAGE to a derivation for SYSTEM, optionally cross-compiled for
(content-hash-value hash)
name #:system system))
(($ <origin> uri method hash name (= force (patches ...)) snippet
- (flags ...) inputs (modules ...) guile-for-build)
+ flags inputs (modules ...) guile-for-build)
;; Patches and/or a snippet.
(mlet %store-monad ((source (method uri
(content-hash-algorithm hash)
HCoop / jackhill / guix / guix.git / blobdiff