me
/
guix
Archived
1
0
Fork 0

packages: 'package-transitive-supported-systems' detects cycles.

With this change, commands such as 'guix build' or 'guix package' report
obvious package-level cycles upfront.  Derivation-level cycles are not
detected.

* guix/packages.scm (&package-cyclic-dependency-error): New condition
type.
(package-transitive-supported-systems): Define 'visited', check it, and
parameterize it.
* guix/ui.scm (call-with-error-handling): Handle
'&package-cyclic-dependency-error'.
* tests/packages.scm ("package-transitive-supported-systems detects
cycles"): Add test.
master
Ludovic Courtès 2023-06-05 23:41:37 +02:00
parent 35c27ec5ee
commit e4259d4e9e
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
3 changed files with 56 additions and 11 deletions

View File

@ -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)

View File

@ -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))

View File

@ -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'.