Merge branch 'master' into xorg-updates

This commit is contained in:
Mark H Weaver 2014-12-24 10:07:03 -05:00
commit f948656c17
3 changed files with 71 additions and 73 deletions

View File

@ -105,24 +105,29 @@
(append environment `((,%distro-root-directory . "gnu/packages")))))) (append environment `((,%distro-root-directory . "gnu/packages"))))))
(define* (scheme-files directory) (define* (scheme-files directory)
"Return the list of Scheme files found under DIRECTORY." "Return the list of Scheme files found under DIRECTORY, recursively. The
(file-system-fold (const #t) ; enter? returned list is sorted in alphabetical order."
(lambda (path stat result) ; leaf
(if (string-suffix? ".scm" path) ;; Sort entries so that 'fold-packages' works in a deterministic fashion
(cons path result) ;; regardless of details of the underlying file system.
result)) (sort (file-system-fold (const #t) ; enter?
(lambda (path stat result) ; down (lambda (path stat result) ; leaf
result) (if (string-suffix? ".scm" path)
(lambda (path stat result) ; up (cons path result)
result) result))
(const #f) ; skip (lambda (path stat result) ; down
(lambda (path stat errno result) result)
(warning (_ "cannot access `~a': ~a~%") (lambda (path stat result) ; up
path (strerror errno)) result)
result) (const #f) ; skip
'() (lambda (path stat errno result)
directory (warning (_ "cannot access `~a': ~a~%")
stat)) path (strerror errno))
result)
'()
directory
stat)
string<?))
(define file-name->module-name (define file-name->module-name
(let ((not-slash (char-set-complement (char-set #\/)))) (let ((not-slash (char-set-complement (char-set #\/))))

View File

@ -55,8 +55,7 @@ PYTHON-BUILD-SYSTEM, such that it is compiled with PYTHON instead. The
inputs are changed recursively accordingly. If the name of P starts with inputs are changed recursively accordingly. If the name of P starts with
OLD-PREFIX, this is replaced by NEW-PREFIX; otherwise, NEW-PREFIX is OLD-PREFIX, this is replaced by NEW-PREFIX; otherwise, NEW-PREFIX is
prepended to the name." prepended to the name."
(let* ((build-system (package-build-system p)) (let* ((rewrite-if-package
(rewrite-if-package
(lambda (content) (lambda (content)
;; CONTENT may be a file name, in which case it is returned, or a ;; CONTENT may be a file name, in which case it is returned, or a
;; package, which is rewritten with the new PYTHON and NEW-PREFIX. ;; package, which is rewritten with the new PYTHON and NEW-PREFIX.
@ -68,28 +67,23 @@ prepended to the name."
(match-lambda (match-lambda
((name content . rest) ((name content . rest)
(append (list name (rewrite-if-package content)) rest))))) (append (list name (rewrite-if-package content)) rest)))))
(package (inherit p)
(name (if (eq? (package-build-system p) python-build-system)
(let ((name (package-name p))) (package (inherit p)
(if (eq? build-system python-build-system) (name (let ((name (package-name p)))
(string-append new-prefix (string-append new-prefix
(if (string-prefix? old-prefix name) (if (string-prefix? old-prefix name)
(substring name (string-length old-prefix)) (substring name (string-length old-prefix))
name)) name))))
name))) (arguments
(arguments (let ((arguments (package-arguments p)))
(let ((arguments (package-arguments p))) (if (member #:python arguments)
(if (eq? build-system python-build-system) (substitute-keyword-arguments arguments ((#:python p) python))
(if (member #:python arguments) (append arguments `(#:python ,python)))))
(substitute-keyword-arguments arguments ((#:python p) python)) (inputs (map rewrite (package-inputs p)))
(append arguments `(#:python ,python))) (propagated-inputs (map rewrite (package-propagated-inputs p)))
arguments))) (native-inputs (map rewrite (package-native-inputs p))))
(inputs p)))
(map rewrite (package-inputs p)))
(propagated-inputs
(map rewrite (package-propagated-inputs p)))
(native-inputs
(map rewrite (package-native-inputs p))))))
(define package-with-python2 (define package-with-python2
(cut package-with-explicit-python <> (default-python2) "python-" "python2-")) (cut package-with-explicit-python <> (default-python2) "python-" "python2-"))

View File

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Mark H Weaver <mhw@netris.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -543,40 +544,38 @@ for the host system (\"native inputs\"), and not target inputs."
recursively." recursively."
(transitive-inputs (package-propagated-inputs package))) (transitive-inputs (package-propagated-inputs package)))
(define-syntax-rule (first-value exp) (define-syntax define-memoized/v
"Truncate all but the first value returned by EXP." (lambda (form)
(call-with-values (lambda () exp) "Define a memoized single-valued unary procedure with docstring.
(lambda (result . _) The procedure argument is compared to cached keys using `eqv?'."
result))) (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 (package-transitive-supported-systems package) (define-memoized/v (package-transitive-supported-systems package)
"Return the intersection of the systems supported by PACKAGE and those "Return the intersection of the systems supported by PACKAGE and those
supported by its dependencies." supported by its dependencies."
(first-value (fold (lambda (input systems)
(let loop ((package package) (match input
(systems (package-supported-systems package)) ((label (? package? p) . _)
(visited vlist-null)) (lset-intersection
(match (vhash-assq package visited) string=? systems (package-transitive-supported-systems p)))
((_ . result) (_
(values (lset-intersection string=? systems result) systems)))
visited)) (package-supported-systems package)
(#f (package-direct-inputs package)))
(call-with-values
(lambda ()
(fold2 (lambda (input systems visited)
(match input
((label (? package? package) . _)
(loop package systems visited))
(_
(values systems visited))))
(lset-intersection string=?
systems
(package-supported-systems package))
visited
(package-direct-inputs package)))
(lambda (systems visited)
(values systems
(vhash-consq package systems visited)))))))))
(define (bag-transitive-inputs bag) (define (bag-transitive-inputs bag)
"Same as 'package-transitive-inputs', but applied to a bag." "Same as 'package-transitive-inputs', but applied to a bag."