diff options
Diffstat (limited to 'guix-qa-frontpage/view/shared.scm')
| -rw-r--r-- | guix-qa-frontpage/view/shared.scm | 169 |
1 files changed, 99 insertions, 70 deletions
diff --git a/guix-qa-frontpage/view/shared.scm b/guix-qa-frontpage/view/shared.scm index e1f26ab..3112028 100644 --- a/guix-qa-frontpage/view/shared.scm +++ b/guix-qa-frontpage/view/shared.scm @@ -578,7 +578,8 @@ (define (package-changes-summary-table revisions derivation-changes-counts - package-changes-url-prefix) + package-changes-url-prefix + systems-affecting-status) (define* (package-derivations-comparison-link system #:key build-change) @@ -598,6 +599,76 @@ (simple-format #f "&build_change=~A" build-change) ""))) + (define* (system+derivations->tr system derivations + #:key bad-highlighting) + (define (count side status) + (assoc-ref (assoc-ref + derivations + side) + status)) + `(tr + (td (@ (class "monospace")) ,system) + ,@(map (lambda (status) + `(td ,(count 'base status))) + '(succeeding failing blocked unknown)) + (td ,@(if (and (>= (count 'target 'succeeding) + (count 'base 'succeeding)) + (> (count 'target 'succeeding) + 0)) + `((@ (class "good"))) + '()) + (a (@ (href + ,(string-append + package-changes-url-prefix + "/package-changes?" + system "-change=fixed&" + system "-change=still-working&" + system "-change=unknown-to-working&" + system "-change=new-working"))) + ,(count 'target 'succeeding))) + (td ,@(if (and bad-highlighting + (> (count 'target 'failing) + (count 'base 'failing))) + '((@ (class "bad"))) + '()) + (a (@ (href + ,(string-append + package-changes-url-prefix + "/package-changes?" + system "-change=broken&" + system "-change=still-failing&" + system "-change=unknown-to-failing&" + system "-change=new-failing"))) + ,(count 'target 'failing))) + (td ,@(if (and bad-highlighting + (> (count 'target 'blocked) + (count 'base 'blocked))) + '((@ (class "bad"))) + '()) + (a (@ (href + ,(string-append + package-changes-url-prefix + "/package-changes?" + system "-change=blocked&" + system "-change=still-blocked&" + system "-change=unknown-to-blocked&" + system "-change=new-blocked"))) + ,(count 'target 'blocked))) + (td (@ ,@(if (and bad-highlighting + (> (count 'target 'unknown) + (count 'base 'unknown))) + '((class "pending")) + '())) + (a (@ (href + ,(string-append + package-changes-url-prefix + "/package-changes?" + system "-change=unknown"))) + ,(count 'target 'unknown))) + (td (a (@ (href + ,(package-derivations-comparison-link system))) + "View comparison")))) + `(table (@ (style "border-collapse: collapse;")) (thead @@ -641,75 +712,33 @@ `((tr (td (@ (colspan 7)) "No package derivation changes"))) - (map - (match-lambda - ((system . derivations) - - (define (count side status) - (assoc-ref (assoc-ref - derivations - side) - status)) - `(tr - (td (@ (class "monospace")) ,system) - ,@(map (lambda (status) - `(td ,(count 'base status))) - '(succeeding failing blocked unknown)) - (td ,@(if (and (>= (count 'target 'succeeding) - (count 'base 'succeeding)) - (> (count 'target 'succeeding) - 0)) - `((@ (class "good"))) - '()) - (a (@ (href - ,(string-append - package-changes-url-prefix - "/package-changes?" - system "-change=fixed&" - system "-change=still-working&" - system "-change=unknown-to-working&" - system "-change=new-working"))) - ,(count 'target 'succeeding))) - (td ,@(if (> (count 'target 'failing) - (count 'base 'failing)) - '((@ (class "bad"))) - '()) - (a (@ (href - ,(string-append - package-changes-url-prefix - "/package-changes?" - system "-change=broken&" - system "-change=still-failing&" - system "-change=unknown-to-failing&" - system "-change=new-failing"))) - ,(count 'target 'failing))) - (td ,@(if (> (count 'target 'blocked) - (count 'base 'blocked)) - '((@ (class "bad"))) - '()) - (a (@ (href - ,(string-append - package-changes-url-prefix - "/package-changes?" - system "-change=blocked&" - system "-change=still-blocked&" - system "-change=unknown-to-blocked&" - system "-change=new-blocked"))) - ,(count 'target 'blocked))) - (td (@ ,@(if (> (count 'target 'unknown) - (count 'base 'unknown)) - '((class "bad")) - '())) - (a (@ (href - ,(string-append - package-changes-url-prefix - "/package-changes?" - system "-change=unknown"))) - ,(count 'target 'unknown))) - (td (a (@ (href - ,(package-derivations-comparison-link system))) - "View comparison"))))) - derivation-changes-counts)) + (match (fold + (lambda (system result) + (if (member system systems-affecting-status) + (cons `(,@(car result) ,system) + (cdr result)) + (cons (car result) + `(,@(cdr result) ,system)))) + (cons '() '()) + (map car derivation-changes-counts)) + ((important-systems . other-systems) + (list + (append + (map + (lambda (system) + (system+derivations->tr + system + (assoc-ref derivation-changes-counts system) + #:bad-highlighting #t)) + important-systems) + `((tr (td (@ (colspan 10)) + "Build status for the below systems doesn't affect issue status"))) + (map + (lambda (system) + (system+derivations->tr + system + (assoc-ref derivation-changes-counts system))) + other-systems)))))) `((tr (td (@ (colspan 10) (class "bad")) |