diff options
| -rw-r--r-- | .dir-locals.el | 2 | ||||
| -rw-r--r-- | Makefile.am | 3 | ||||
| -rw-r--r-- | guix/profiles.scm | 70 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 26 | ||||
| -rw-r--r-- | tests/profiles.scm | 97 |
5 files changed, 168 insertions, 30 deletions
diff --git a/.dir-locals.el b/.dir-locals.el index dc1a3d724d..240fae1c12 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -14,6 +14,8 @@ (eval . (put 'substitute* 'scheme-indent-function 1)) (eval . (put 'with-directory-excursion 'scheme-indent-function 1)) (eval . (put 'package 'scheme-indent-function 0)) + (eval . (put 'manifest-entry 'scheme-indent-function 0)) + (eval . (put 'manifest-pattern 'scheme-indent-function 0)) (eval . (put 'substitute-keyword-arguments 'scheme-indent-function 1)) (eval . (put 'with-error-handling 'scheme-indent-function 0)) (eval . (put 'with-mutex 'scheme-indent-function 1)) diff --git a/Makefile.am b/Makefile.am index 1960b1b76d..9462878d1c 100644 --- a/Makefile.am +++ b/Makefile.am @@ -115,7 +115,8 @@ SCM_TESTS = \ tests/store.scm \ tests/monads.scm \ tests/nar.scm \ - tests/union.scm + tests/union.scm \ + tests/profiles.scm SH_TESTS = \ tests/guix-build.sh \ diff --git a/guix/profiles.scm b/guix/profiles.scm index 528f3c574b..1f62099e45 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -42,11 +42,15 @@ manifest-entry-path manifest-entry-dependencies + manifest-pattern + manifest-pattern? + read-manifest write-manifest manifest-remove manifest-installed? + manifest-matching-entries manifest=? profile-manifest @@ -90,6 +94,15 @@ (inputs manifest-entry-inputs ; list of inputs to build (default '()))) ; this entry +(define-record-type* <manifest-pattern> manifest-pattern + make-manifest-pattern + manifest-pattern? + (name manifest-pattern-name) ; string + (version manifest-pattern-version ; string | #f + (default #f)) + (output manifest-pattern-output ; string | #f + (default "out"))) + (define (profile-manifest profile) "Return the PROFILE's manifest." (let ((file (string-append profile "/manifest"))) @@ -148,29 +161,48 @@ "Write MANIFEST to PORT." (write (manifest->sexp manifest) port)) -(define (remove-manifest-entry name lst) - "Remove the manifest entry named NAME from LST." - (remove (match-lambda - (($ <manifest-entry> entry-name) - (string=? name entry-name))) - lst)) - -(define (manifest-remove manifest names) - "Remove entries for each of NAMES from MANIFEST." - (make-manifest (fold remove-manifest-entry +(define (entry-predicate pattern) + "Return a procedure that returns #t when passed a manifest entry that +matches NAME/OUTPUT/VERSION. OUTPUT and VERSION may be #f, in which case they +are ignored." + (match pattern + (($ <manifest-pattern> name version output) + (match-lambda + (($ <manifest-entry> entry-name entry-version entry-output) + (and (string=? entry-name name) + (or (not entry-output) (not output) + (string=? entry-output output)) + (or (not version) + (string=? entry-version version)))))))) + +(define (manifest-remove manifest patterns) + "Remove entries for each of PATTERNS from MANIFEST. Each item in PATTERNS +must be a manifest-pattern." + (define (remove-entry pattern lst) + (remove (entry-predicate pattern) lst)) + + (make-manifest (fold remove-entry (manifest-entries manifest) - names))) - -(define (manifest-installed? manifest name) - "Return #t if MANIFEST has an entry for NAME, #f otherwise." - (define (->bool x) - (not (not x))) + patterns))) - (->bool (find (match-lambda - (($ <manifest-entry> entry-name) - (string=? entry-name name))) +(define (manifest-installed? manifest pattern) + "Return #t if MANIFEST has an entry matching PATTERN (a manifest-pattern), +#f otherwise." + (->bool (find (entry-predicate pattern) (manifest-entries manifest)))) +(define (manifest-matching-entries manifest patterns) + "Return all the entries of MANIFEST that match one of the PATTERNS." + (define predicates + (map entry-predicate patterns)) + + (define (matches? entry) + (any (lambda (pred) + (pred entry)) + predicates)) + + (filter matches? (manifest-entries manifest))) + (define (manifest=? m1 m2) "Return #t if manifests M1 and M2 are equal. This differs from 'equal?' in that the 'inputs' field is ignored for the comparison, since it is know to diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index e0c7b6ed15..77406c7f39 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -693,15 +693,20 @@ return the new list of manifest entries." (append to-upgrade to-install)) (define (options->removable options manifest) - "Given options, return the list of manifest entries to be removed from -MANIFEST." - (let ((remove (filter-map (match-lambda - (('remove . package) - package) - (_ #f)) - options))) - (filter (cut manifest-installed? manifest <>) - remove))) + "Given options, return the list of manifest patterns of packages to be +removed from MANIFEST." + (filter-map (match-lambda + (('remove . spec) + (call-with-values + (lambda () + (package-specification->name+version+output spec)) + (lambda (name version output) + (manifest-pattern + (name name) + (version version) + (output output))))) + (_ #f)) + options)) ;;; @@ -871,7 +876,8 @@ more information.~%")) (if (manifest=? new manifest) (format (current-error-port) (_ "nothing to be done~%")) - (let ((prof-drv (profile-derivation (%store) new))) + (let ((prof-drv (profile-derivation (%store) new)) + (remove (manifest-matching-entries manifest remove))) (show-what-to-remove/install remove install dry-run?) (show-what-to-build (%store) (list prof-drv) #:use-substitutes? diff --git a/tests/profiles.scm b/tests/profiles.scm new file mode 100644 index 0000000000..8ead6e6968 --- /dev/null +++ b/tests/profiles.scm @@ -0,0 +1,97 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (test-profiles) + #:use-module (guix profiles) + #:use-module (ice-9 match) + #:use-module (srfi srfi-64)) + +;; Test the (guix profile) module. + + +;; Example manifest entries. + +(define guile-2.0.9 + (manifest-entry + (name "guile") + (version "2.0.9") + (path "/gnu/store/...") + (output "out"))) + +(define guile-2.0.9:debug + (manifest-entry (inherit guile-2.0.9) + (output "debug"))) + + +(test-begin "profiles") + +(test-assert "manifest-installed?" + (let ((m (manifest (list guile-2.0.9 guile-2.0.9:debug)))) + (and (manifest-installed? m (manifest-pattern (name "guile"))) + (manifest-installed? m (manifest-pattern + (name "guile") (output "debug"))) + (manifest-installed? m (manifest-pattern + (name "guile") (output "out") + (version "2.0.9"))) + (not (manifest-installed? + m (manifest-pattern (name "guile") (version "1.8.8")))) + (not (manifest-installed? + m (manifest-pattern (name "guile") (output "foobar"))))))) + +(test-assert "manifest-matching-entries" + (let* ((e (list guile-2.0.9 guile-2.0.9:debug)) + (m (manifest e))) + (and (null? (manifest-matching-entries m + (list (manifest-pattern + (name "python"))))) + (equal? e + (manifest-matching-entries m + (list (manifest-pattern + (name "guile") + (output #f))))) + (equal? (list guile-2.0.9) + (manifest-matching-entries m + (list (manifest-pattern + (name "guile") + (version "2.0.9")))))))) + +(test-assert "manifest-remove" + (let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug))) + (m1 (manifest-remove m0 + (list (manifest-pattern (name "guile"))))) + (m2 (manifest-remove m1 + (list (manifest-pattern (name "guile"))))) ; same + (m3 (manifest-remove m2 + (list (manifest-pattern + (name "guile") (output "debug"))))) + (m4 (manifest-remove m3 + (list (manifest-pattern (name "guile")))))) + (match (manifest-entries m2) + ((($ <manifest-entry> "guile" "2.0.9" "debug")) + (and (equal? m1 m2) + (null? (manifest-entries m3)) + (null? (manifest-entries m4))))))) + +(test-end "profiles") + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) + +;;; Local Variables: +;;; eval: (put 'dummy-package 'scheme-indent-function 1) +;;; End: |