Merge branch 'master' into xorg-updates
This commit is contained in:
commit
f948656c17
@ -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 #\/))))
|
||||||
|
@ -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-"))
|
||||||
|
@ -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."
|
||||||
|
Loading…
Reference in New Issue
Block a user