;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2014, 2015 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2017 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
+;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (guix base32)
#:use-module (guix grafts)
#:use-module (guix derivations)
+ #:use-module (guix memoization)
#:use-module (guix build-system)
#:use-module (guix search-paths)
- #:use-module (guix gexp)
#:use-module (guix sets)
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
package-transitive-propagated-inputs
package-transitive-native-search-paths
package-transitive-supported-systems
+ package-mapping
package-input-rewriting
package-source-derivation
package-derivation
package-cross-derivation
package-output
package-grafts
+ package/inherit
transitive-input-references
(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" "mips64el-linux"))
+ '("x86_64-linux" "i686-linux" "armhf-linux" "aarch64-linux" "mips64el-linux"))
(define %hurd-systems
;; The GNU/Hurd systems for which support is being developed.
'("i585-gnu" "i686-gnu"))
(define %hydra-supported-systems
- ;; This is the list of system types for which build slaves are available.
- %supported-systems)
+ ;; This is the list of system types for which build machines are available.
+ ;;
+ ;; XXX: MIPS is temporarily unavailable on Hydra:
+ ;; <https://lists.gnu.org/archive/html/guix-devel/2017-03/msg00790.html>.
+ (fold delete %supported-systems '("aarch64-linux" "mips64el-linux")))
;; A package.
; inputs
(native-search-paths package-native-search-paths (default '()))
(search-paths package-search-paths (default '()))
+
+ ;; The 'replacement' field is marked as "innate" because it never makes
+ ;; sense to inherit a replacement as is. See the 'package/inherit' macro.
(replacement package-replacement ; package | #f
- (default #f) (thunked))
+ (default #f) (thunked) (innate))
(synopsis package-synopsis) ; one-line description
(description package-description) ; one or two paragraphs
(define-condition-type &package-cross-build-system-error &package-error
package-cross-build-system-error?)
-
-(define (package-full-name package)
- "Return the full name of PACKAGE--i.e., `NAME-VERSION'."
- (string-append (package-name package) "-" (package-version package)))
+(define* (package-full-name package #:optional (delimiter "@"))
+ "Return the full name of PACKAGE--i.e., `NAME@VERSION'. By specifying
+DELIMITER (a string), you can customize what will appear between the name and
+the version. By default, DELIMITER is \"@\"."
+ (string-append (package-name package) delimiter (package-version package)))
(define (%standard-patch-inputs)
(let* ((canonical (module-ref (resolve-interface '(gnu packages base))
("bzip2" ,(ref '(gnu packages compression) 'bzip2))
("gzip" ,(ref '(gnu packages compression) 'gzip))
("lzip" ,(ref '(gnu packages compression) 'lzip))
- ("unzip" ,(ref '(gnu packages zip) 'unzip))
+ ("unzip" ,(ref '(gnu packages compression) 'unzip))
("patch" ,(ref '(gnu packages base) 'patch))
("locales" ,(ref '(gnu packages base) 'glibc-utf8-locales)))))
(let ((distro (resolve-interface '(gnu packages commencement))))
(module-ref distro 'guile-final)))
+(define (guile-2.0)
+ "Return Guile 2.0."
+ ;; FIXME: This is used as a workaround for <https://bugs.gnu.org/28211> when
+ ;; grafting packages.
+ (let ((distro (resolve-interface '(gnu packages guile))))
+ (module-ref distro 'guile-2.0)))
+
(define* (default-guile-derivation #:optional (system (%current-system)))
"Return the derivation for SYSTEM of the default Guile package used to run
the build code of derivation."
(define instantiate-patch
(match-lambda
- ((? string? patch)
+ ((? string? patch) ;deprecated
(interned-file patch #:recursive? #t))
- ((? origin? patch)
- (origin->derivation patch system))))
+ ((? struct? patch) ;origin, local-file, etc.
+ (lower-object patch system))))
(mlet %store-monad ((tar -> (lookup-input "tar"))
(xz -> (lookup-input "xz"))
(setenv "LOCPATH"
(string-append #+locales "/lib/locale/"
#+(and locales
- (package-version locales))))
+ (version-major+minor
+ (package-version locales)))))
(setlocale LC_ALL "en_US.utf8"))
(setenv "PATH" (string-append #+xz "/bin" ":"
#:fail-on-error? #t)))))
(zero? (apply system*
(string-append #+tar "/bin/tar")
- "cvfa" #$output
+ "cvf" #$output
+ ;; The bootstrap xz does not support
+ ;; threaded compression (introduced in
+ ;; 5.2.0), but it ignores the extra flag.
+ (string-append "--use-compress-program="
+ #+xz "/bin/xz --threads=0")
;; avoid non-determinism in the archive
"--mtime=@0"
"--owner=root:0"
(gexp->derivation name build
#:graft? #f
#:system system
+ #:deprecation-warnings #t ;to avoid a rebuild
#:guile-for-build guile-for-build))))
(define (transitive-inputs inputs)
This is implemented as a breadth-first traversal such that INPUTS is
preserved, and only duplicate propagated inputs are removed."
(define (seen? seen item outputs)
+ ;; FIXME: We're using pointer identity here, which is extremely sensitive
+ ;; to memoization in package-producing procedures; see
+ ;; <https://bugs.gnu.org/30155>.
(match (vhash-assq item seen)
((_ . o) (equal? o outputs))
(_ #f)))
`(assoc-ref ,alist ,(label input)))
(transitive-inputs inputs)))
-(define-syntax define-memoized/v
- (lambda (form)
- "Define a memoized single-valued unary procedure with docstring.
-The procedure argument is compared to cached keys using `eqv?'."
- (syntax-case form ()
- ((_ (proc arg) docstring body body* ...)
- (string? (syntax->datum #'docstring))
- #'(define proc
- (let ((cache (make-hash-table)))
- (define (proc arg)
- docstring
- (match (hashv-get-handle cache arg)
- ((_ . value)
- value)
- (_
- (let ((result (let () body body* ...)))
- (hashv-set! cache arg result)
- result))))
- proc))))))
-
-(define-memoized/v (package-transitive-supported-systems package)
- "Return the intersection of the systems supported by PACKAGE and those
+(define package-transitive-supported-systems
+ (mlambdaq (package)
+ "Return the intersection of the systems supported by PACKAGE and those
supported by its dependencies."
- (fold (lambda (input systems)
- (match input
- ((label (? package? p) . _)
- (lset-intersection
- string=? systems (package-transitive-supported-systems p)))
- (_
- systems)))
- (package-supported-systems package)
- (bag-direct-inputs (package->bag package))))
+ (fold (lambda (input systems)
+ (match input
+ ((label (? package? p) . _)
+ (lset-intersection
+ string=? systems (package-transitive-supported-systems p)))
+ (_
+ systems)))
+ (package-supported-systems package)
+ (bag-direct-inputs (package->bag package)))))
(define* (supported-package? package #:optional (system (%current-system)))
"Return true if PACKAGE is supported on SYSTEM--i.e., if PACKAGE and all its
"Return the \"target inputs\" of BAG, recursively."
(transitive-inputs (bag-target-inputs bag)))
+(define* (package-mapping proc #:optional (cut? (const #f)))
+ "Return a procedure that, given a package, applies PROC to all the packages
+depended on and returns the resulting package. The procedure stops recursion
+when CUT? returns true for a given package."
+ (define (rewrite input)
+ (match input
+ ((label (? package? package) outputs ...)
+ (let ((proc (if (cut? package) proc replace)))
+ (cons* label (proc package) outputs)))
+ (_
+ input)))
+
+ (define replace
+ (mlambdaq (p)
+ ;; Return a variant of P with PROC applied to P and its explicit
+ ;; dependencies, recursively. Memoize the transformations. Failing to
+ ;; do that, we would build a huge object graph with lots of duplicates,
+ ;; which in turns prevents us from benefiting from memoization in
+ ;; 'package-derivation'.
+ (let ((p (proc p)))
+ (package
+ (inherit p)
+ (location (package-location p))
+ (inputs (map rewrite (package-inputs p)))
+ (native-inputs (map rewrite (package-native-inputs p)))
+ (propagated-inputs (map rewrite (package-propagated-inputs p)))
+ (replacement (and=> (package-replacement p) proc))))))
+
+ replace)
+
(define* (package-input-rewriting replacements
#:optional (rewrite-name identity))
"Return a procedure that, when passed a package, replaces its direct and
Optionally, REWRITE-NAME is a one-argument procedure that takes the name of a
package and returns its new name after rewrite."
- (define (rewrite input)
- (match input
- ((label (? package? package) outputs ...)
- (match (assq-ref replacements package)
- (#f (cons* label (replace package) outputs))
- (new (cons* label new outputs))))
- (_
- input)))
-
- (define-memoized/v (replace p)
- "Return a variant of P with its inputs rewritten."
- (package
- (inherit p)
- (name (rewrite-name (package-name p)))
- (inputs (map rewrite (package-inputs p)))
- (native-inputs (map rewrite (package-native-inputs p)))
- (propagated-inputs (map rewrite (package-propagated-inputs p)))))
-
- replace)
+ (define (rewrite p)
+ (match (assq-ref replacements p)
+ (#f (package
+ (inherit p)
+ (name (rewrite-name (package-name p)))))
+ (new new)))
+
+ (package-mapping rewrite (cut assq <> replacements)))
+
+(define-syntax-rule (package/inherit p overrides ...)
+ "Like (package (inherit P) OVERRIDES ...), except that the same
+transformation is done to the package replacement, if any. P must be a bare
+identifier, and will be bound to either P or its replacement when evaluating
+OVERRIDES."
+ (let loop ((p p))
+ (package (inherit p)
+ overrides ...
+ (replacement (and=> (package-replacement p) loop)))))
\f
;;;
;; source.
(list name (intern file)))
(((? string? name) (? struct? source))
- (list name (package-source-derivation store source system)))
+ ;; '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)
(($ <package> name version source build-system
args inputs propagated-inputs native-inputs
self-native-input? outputs)
+ ;; Even though we prefer to use "@" to separate the package
+ ;; name from the package version in various user-facing parts
+ ;; of Guix, checkStoreName (in nix/libstore/store-api.cc)
+ ;; prohibits the use of "@", so use "-" instead.
(or (make-bag build-system (string-append name "-" version)
#:system system
#:target target
"Fold PROC over the packages BAG depends on. Each package is visited only
once, in depth-first order. If NATIVE? is true, restrict to native
dependencies; otherwise, restrict to target dependencies."
+ (define bag-direct-inputs*
+ (if native?
+ (lambda (bag)
+ (append (bag-build-inputs bag)
+ (bag-target-inputs bag)
+ (if (bag-target bag)
+ '()
+ (bag-host-inputs bag))))
+ bag-host-inputs))
+
(define nodes
- (match (if native?
- (append (bag-build-inputs bag)
- (bag-target-inputs bag)
- (if (bag-target bag)
- '()
- (bag-host-inputs bag)))
- (bag-host-inputs bag))
+ (match (bag-direct-inputs* bag)
(((labels things _ ...) ...)
things)))
(((? package? head) . tail)
(if (set-contains? visited head)
(loop tail result visited)
- (let ((inputs (bag-direct-inputs (package->bag head))))
+ (let ((inputs (bag-direct-inputs* (package->bag head))))
(loop (match inputs
(((labels things _ ...) ...)
(append things tail)))
(()
drv)
(grafts
- (let ((guile (package-derivation store (default-guile)
+ (let ((guile (package-derivation store (guile-2.0)
system #:graft? #f)))
;; TODO: As an optimization, we can simply graft the tip
;; of the derivation graph since 'graft-derivation'
(graft-derivation store drv grafts
#:system system
#:guile
- (package-derivation store (default-guile)
+ (package-derivation store (guile-2.0)
system #:graft? #f))))
drv))))
HCoop / jackhill / guix / guix.git / blobdiff