futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' into xorg-updates

Browse Source
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
gnu/packages.scm
View File

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

42
guix/build-system/python.scm
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
OLD-PREFIX, this is replaced by NEW-PREFIX; otherwise, NEW-PREFIX is
prepended to the name."
(let* ((build-system (package-build-system p))
(rewrite-if-package
(let* ((rewrite-if-package
(lambda (content)
;; 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.
@ -68,28 +67,23 @@ prepended to the name."
(match-lambda
((name content . rest)
(append (list name (rewrite-if-package content)) rest)))))
(package (inherit p)
(name
(let ((name (package-name p)))
(if (eq? build-system python-build-system)
(string-append new-prefix
(if (string-prefix? old-prefix name)
(substring name (string-length old-prefix))
name))
name)))
(arguments
(let ((arguments (package-arguments p)))
(if (eq? build-system python-build-system)
(if (member #:python arguments)
(substitute-keyword-arguments arguments ((#:python p) python))
(append arguments `(#:python ,python)))
arguments)))
(inputs
(map rewrite (package-inputs p)))
(propagated-inputs
(map rewrite (package-propagated-inputs p)))
(native-inputs
(map rewrite (package-native-inputs p))))))
(if (eq? (package-build-system p) python-build-system)
(package (inherit p)
(name (let ((name (package-name p)))
(string-append new-prefix
(if (string-prefix? old-prefix name)
(substring name (string-length old-prefix))
name))))
(arguments
(let ((arguments (package-arguments p)))
(if (member #:python arguments)
(substitute-keyword-arguments arguments ((#:python p) python))
(append arguments `(#:python ,python)))))
(inputs (map rewrite (package-inputs p)))
(propagated-inputs (map rewrite (package-propagated-inputs p)))
(native-inputs (map rewrite (package-native-inputs p))))
p)))
(define package-with-python2
(cut package-with-explicit-python <> (default-python2) "python-" "python2-"))

61
guix/packages.scm
View File

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; 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.
;;;
@ -543,40 +544,38 @@ for the host system (\"native inputs\"), and not target inputs."
recursively."
(transitive-inputs (package-propagated-inputs package)))
(define-syntax-rule (first-value exp)
"Truncate all but the first value returned by EXP."
(call-with-values (lambda () exp)
(lambda (result . _)
result)))
(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 (package-transitive-supported-systems package)
(define-memoized/v (package-transitive-supported-systems package)
"Return the intersection of the systems supported by PACKAGE and those
supported by its dependencies."
(first-value
(let loop ((package package)
(systems (package-supported-systems package))
(visited vlist-null))
(match (vhash-assq package visited)
((_ . result)
(values (lset-intersection string=? systems result)
visited))
(#f
(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)))))))))
(fold (lambda (input systems)
(match input
((label (? package? p) . _)
(lset-intersection
string=? systems (package-transitive-supported-systems p)))
(_
systems)))
(package-supported-systems package)
(package-direct-inputs package)))
(define (bag-transitive-inputs bag)
"Same as 'package-transitive-inputs', but applied to a bag."