;;; 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 © 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 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.
;;
;; XXX: MIPS is temporarily unavailable on Hydra:
;; <https://lists.gnu.org/archive/html/guix-devel/2017-03/msg00790.html>.
- (delete "mips64el-linux" %supported-systems))
+ (fold delete %supported-systems '("aarch64-linux" "mips64el-linux")))
;; A package.
"Return the \"target inputs\" of BAG, recursively."
(transitive-inputs (bag-target-inputs bag)))
-(define* (package-input-rewriting replacements
- #:optional (rewrite-name identity))
- "Return a procedure that, when passed a package, replaces its direct and
-indirect dependencies (but not its implicit inputs) according to REPLACEMENTS.
-REPLACEMENTS is a list of package pairs; the first element of each pair is the
-package to replace, and the second one is the replacement.
-
-Optionally, REWRITE-NAME is a one-argument procedure that takes the name of a
-package and returns its new name after rewrite."
+(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 ...)
- (match (assq-ref replacements package)
- (#f (cons* label (replace package) outputs))
- (new (cons* label new outputs))))
+ (let ((proc (if (cut? package) proc replace)))
+ (cons* label (proc package) outputs)))
(_
input)))
(define replace
(mlambdaq (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))))))
+ ;; 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)))))))
replace)
+(define* (package-input-rewriting replacements
+ #:optional (rewrite-name identity))
+ "Return a procedure that, when passed a package, replaces its direct and
+indirect dependencies (but not its implicit inputs) according to REPLACEMENTS.
+REPLACEMENTS is a list of package pairs; the first element of each pair is the
+package to replace, and the second one is the replacement.
+
+Optionally, REWRITE-NAME is a one-argument procedure that takes the name of a
+package and returns its new name after rewrite."
+ (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
;;;
;;; Package derivations.
;; 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)
HCoop / jackhill / guix / guix.git / blobdiff