diff options
| -rw-r--r-- | guix/packages.scm | 41 | ||||
| -rw-r--r-- | guix/ui.scm | 9 | ||||
| -rw-r--r-- | tests/packages.scm | 17 |
3 files changed, 56 insertions, 11 deletions
diff --git a/guix/packages.scm b/guix/packages.scm index e26602d589..ba98bb0fb4 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -168,6 +168,9 @@ package-error-invalid-license &package-input-error package-input-error? + &package-cyclic-dependency-error + package-cyclic-dependency-error? + package-error-dependency-cycle package-error-invalid-input &package-cross-build-system-error package-cross-build-system-error? @@ -806,6 +809,10 @@ exist, return #f instead." package-input-error? (input package-error-invalid-input)) +(define-condition-type &package-cyclic-dependency-error &package-error + package-cyclic-dependency-error? + (cycle package-error-dependency-cycle)) + (define-condition-type &package-cross-build-system-error &package-error package-cross-build-system-error?) @@ -1317,17 +1324,29 @@ in INPUTS and their transitive propagated inputs." (let () (define (supported-systems-procedure system) (define supported-systems - (mlambdaq (package) - (parameterize ((%current-system system)) - (fold (lambda (input systems) - (match input - ((label (? package? package) . _) - (lset-intersection string=? systems - (supported-systems package))) - (_ - systems))) - (package-supported-systems package) - (bag-direct-inputs (package->bag package system #f)))))) + ;; The VISITED parameter allows for cycle detection. This is a pretty + ;; strategic place to do that: most commands call it upfront, yet it's + ;; not on the hot path of 'package->derivation'. The downside is that + ;; only package-level cycles are detected. + (let ((visited (make-parameter (setq)))) + (mlambdaq (package) + (when (set-contains? (visited) package) + (raise (condition + (&package-cyclic-dependency-error + (package package) + (cycle (set->list (visited))))))) + + (parameterize ((visited (set-insert package (visited))) + (%current-system system)) + (fold (lambda (input systems) + (match input + ((label (? package? package) . _) + (lset-intersection string=? systems + (supported-systems package))) + (_ + systems))) + (package-supported-systems package) + (bag-direct-inputs (package->bag package system #f))))))) supported-systems) diff --git a/guix/ui.scm b/guix/ui.scm index 7540e2194f..47a118364a 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -722,6 +722,15 @@ evaluating the tests and bodies of CLAUSES." (leave (G_ "~a:~a:~a: package `~a' has an invalid input: ~s~%") file line column (package-full-name package) input))) + ((package-cyclic-dependency-error? c) + (let ((package (package-error-package c))) + (leave (package-location package) + (G_ "~a: dependency cycle detected: + ~a~{ -> ~a~}~%") + (package-full-name package) + (package-full-name package) + (map package-full-name + (package-error-dependency-cycle c))))) ((package-cross-build-system-error? c) (let* ((package (package-error-package c)) (loc (package-location package)) diff --git a/tests/packages.scm b/tests/packages.scm index 5e8eac99dc..2b7ab01f7d 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -368,6 +368,23 @@ (package-transitive-supported-systems d) (package-transitive-supported-systems e)))) +(test-equal "package-transitive-supported-systems detects cycles" + '("c" "a" "b" "c") + (letrec* ((a (dummy-package "a" + (build-system trivial-build-system) + (native-inputs (list c)))) + (b (dummy-package "b" + (build-system trivial-build-system) + (inputs (list a)))) + (c (dummy-package "c" + (build-system trivial-build-system) + (inputs (list b))))) + (guard (c ((package-cyclic-dependency-error? c) + (map package-name + (cons (package-error-package c) + (package-error-dependency-cycle c))))) + (package-transitive-supported-systems c)))) + (test-assert "package-development-inputs" ;; Note: Due to propagated inputs, 'package-development-inputs' returns a ;; couple more inputs, such as 'linux-libre-headers'. |