Merge branch 'master' into core-updates

1 files changed, 62 insertions, 24 deletions

diff --git a/guix/packages.scm b/guix/packages.scm
index 29351ace1d..97580352e2 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1,8 +1,9 @@
 ;;; 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.
 ;;;
@@ -31,7 +32,6 @@
   #: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)
@@ -99,12 +99,14 @@
             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
 
@@ -223,7 +225,7 @@ name of its URI."
 (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.
@@ -234,7 +236,7 @@ name of its URI."
   ;;
   ;; 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.
@@ -747,36 +749,63 @@ dependencies are known to build on SYSTEM."
   "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)))))
+
 
 ;;;
 ;;; Package derivations.
@@ -851,7 +880,16 @@ information in exceptions."
      ;; 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)