diff options
| -rw-r--r-- | gnu/packages.scm | 41 | ||||
| -rw-r--r-- | guix/build-system/python.scm | 42 | ||||
| -rw-r--r-- | guix/packages.scm | 61 |
3 files changed, 71 insertions, 73 deletions
diff --git a/gnu/packages.scm b/gnu/packages.scm index c9efd0d691..6109d1f896 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -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 #\/)))) diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index 4bba7167ca..e8af9f8146 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -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-")) diff --git a/guix/packages.scm b/guix/packages.scm index 07f6d0ccbc..2a9a55e12f 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -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." |