[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/04: profiles: Raise an error for unmatched patterns.
|
From: |
guix-commits |
|
Subject: |
01/04: profiles: Raise an error for unmatched patterns. |
|
Date: |
Thu, 7 Feb 2019 09:46:54 -0500 (EST) |
civodul pushed a commit to branch master
in repository guix.
commit 487cbb0164c715e722b622fa800fa0b217fa132c
Author: Ludovic Courtès <address@hidden>
Date: Thu Feb 7 14:54:43 2019 +0100
profiles: Raise an error for unmatched patterns.
Previously, "guix package -r something-not-installed" would silently
complete. Now an error is raised.
* guix/profiles.scm (&unmatched-pattern-error): New condition type.
(manifest-matching-entries): Rewrite to raise an error when one of
PATTERNS is not matched.
* guix/ui.scm (call-with-error-handling): Handle 'unmatched-pattern-error?'.
* tests/guix-package.sh: Add test.
* tests/profiles.scm ("manifest-matching-entries"): Don't try to remove
unmatched pattern.
("manifest-matching-entries, no match"): New test.
("manifest-transaction-effects"): Remove 'remove' field.
---
guix/profiles.scm | 34 ++++++++++++++++++++++++----------
guix/ui.scm | 8 ++++++++
tests/guix-package.sh | 7 ++++++-
tests/profiles.scm | 17 +++++++++++------
4 files changed, 49 insertions(+), 17 deletions(-)
diff --git a/guix/profiles.scm b/guix/profiles.scm
index efe5ecb..6564526 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -63,6 +63,10 @@
&missing-generation-error
missing-generation-error?
missing-generation-error-generation
+ &unmatched-pattern-error
+ unmatched-pattern-error?
+ unmatched-pattern-error-pattern
+ unmatched-pattern-error-manifest
manifest make-manifest
manifest?
@@ -156,6 +160,11 @@
(entry profile-collision-error-entry) ;<manifest-entry>
(conflict profile-collision-error-conflict)) ;<manifest-entry>
+(define-condition-type &unmatched-pattern-error &error
+ unmatched-pattern-error?
+ (pattern unmatched-pattern-error-pattern) ;<manifest-pattern>
+ (manifest unmatched-pattern-error-manifest)) ;<manifest>
+
(define-condition-type &missing-generation-error &profile-error
missing-generation-error?
(generation missing-generation-error-generation))
@@ -559,16 +568,21 @@ no match.."
(->bool (manifest-lookup manifest pattern)))
(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)))
+ "Return all the entries of MANIFEST that match one of the PATTERNS. Raise
+an '&unmatched-pattern-error' if none of the entries of MANIFEST matches one
+of PATTERNS."
+ (fold-right (lambda (pattern matches)
+ (match (filter (entry-predicate pattern)
+ (manifest-entries manifest))
+ (()
+ (raise (condition
+ (&unmatched-pattern-error
+ (pattern pattern)
+ (manifest manifest)))))
+ (lst
+ (append lst matches))))
+ '()
+ patterns))
(define (manifest-search-paths manifest)
"Return the list of search path specifications that apply to MANIFEST,
diff --git a/guix/ui.scm b/guix/ui.scm
index 9eab4ba..f046551 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -643,6 +643,14 @@ or remove one of them from the profile.")
(leave (G_ "generation ~a of profile '~a' does not exist~%")
(missing-generation-error-generation c)
(profile-error-profile c)))
+ ((unmatched-pattern-error? c)
+ (let ((pattern (unmatched-pattern-error-pattern c)))
+ (leave (G_ "package 'address@hidden@address@hidden:~a~]' not
found in profile~%")
+ (manifest-pattern-name pattern)
+ (manifest-pattern-version pattern)
+ (match (manifest-pattern-output pattern)
+ ("out" #f)
+ (output output)))))
((profile-collision-error? c)
(let ((entry (profile-collision-error-entry c))
(conflict (profile-collision-error-conflict c)))
diff --git a/tests/guix-package.sh b/tests/guix-package.sh
index 7eeb430..0d60481 100644
--- a/tests/guix-package.sh
+++ b/tests/guix-package.sh
@@ -1,5 +1,5 @@
# GNU Guix --- Functional package management for GNU
-# Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès
<address@hidden>
+# Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès
<address@hidden>
# Copyright © 2013 Nikita Karetnikov <address@hidden>
#
# This file is part of GNU Guix.
@@ -97,6 +97,11 @@ then false; else true; fi
if guix package --bootstrap -i "guile-bootstrap:does-not-exist" -p "$profile";
then false; else true; fi
+# Make sure we get an error when trying to remove something that's not
+# installed.
+if guix package --bootstrap -r something-not-installed -p "$profile";
+then false; else true; fi
+
# Check whether `--list-available' returns something sensible.
guix package -p "$profile" -A 'gui.*e' | grep guile
diff --git a/tests/profiles.scm b/tests/profiles.scm
index 9a05030..eef93e2 100644
--- a/tests/profiles.scm
+++ b/tests/profiles.scm
@@ -93,10 +93,7 @@
(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
+ (and (equal? e
(manifest-matching-entries m
(list (manifest-pattern
(name "guile")
@@ -107,6 +104,15 @@
(name "guile")
(version "2.0.9"))))))))
+(test-assert "manifest-matching-entries, no match"
+ (let ((m (manifest (list guile-2.0.9)))
+ (p (manifest-pattern (name "python"))))
+ (guard (c ((unmatched-pattern-error? c)
+ (and (eq? p (unmatched-pattern-error-pattern c))
+ (eq? m (unmatched-pattern-error-manifest c)))))
+ (manifest-matching-entries m (list p))
+ #f)))
+
(test-assert "manifest-remove"
(let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug)))
(m1 (manifest-remove m0
@@ -165,8 +171,7 @@
(test-assert "manifest-transaction-effects"
(let* ((m0 (manifest (list guile-1.8.8)))
(t (manifest-transaction
- (install (list guile-2.0.9 glibc))
- (remove (list (manifest-pattern (name "coreutils")))))))
+ (install (list guile-2.0.9 glibc)))))
(let-values (((remove install upgrade downgrade)
(manifest-transaction-effects m0 t)))
(and (null? remove) (null? downgrade)