(define-module (guix-qa-frontpage view branch)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:use-module (guix-qa-frontpage manage-builds)
  #:use-module (guix-qa-frontpage derivation-changes)
  #:use-module (guix-qa-frontpage view util)
  #:export (branch-view))

(define (branch-view branch derivation-changes)
  (define* (package-derivations-comparison-link system
                                                #:key build-change)
    (let ((revisions
           (assoc-ref change-details "revisions")))
      (string-append
       (simple-format #f "https://data.qa.guix.gnu.org/compare/package-derivations?base_commit=~A&target_commit=~A&system=~A&target=none"
                      (assoc-ref (assoc-ref revisions "base")
                                 "commit")
                      (assoc-ref (assoc-ref revisions "target")
                                 "commit")
                      system)
       (if build-change
           (simple-format #f "&build_change=~A" build-change)
           ""))))

  (layout
   #:title (simple-format #f "Branch ~A" branch)
   #:body
   `((main


      (div
       (table
        (@ (style "border-collapse: collapse;"))
        (thead
         (tr
          (th (@ (rowspan 3)) "System")
          (th (@ (colspan 6)) "Package build status")
          (th))
         (tr
          (th (@ (colspan 3)) "Base")
          (th (@ (colspan 3)) "With patches applied")
          (th))
         (tr
          (th (@ (style "min-width: 5rem;"))
              "Succeeding")
          (th (@ (style "min-width: 5rem;"))
              "Failing")
          (th (@ (style "min-width: 5rem;"))
              "Unknown")
          (th (@ (style "min-width: 5rem;"))
              "Succeeding")
          (th (@ (style "min-width: 5rem;"))
              "Failing")
          (th (@ (style "min-width: 5rem;"))
              "Unknown")
          (th)))
        (tbody
         ,@(if derivation-changes
               (let* ((base-builds
                       (builds-by-system-excluding-cross-builds
                        derivation-changes "base"))
                      (target-builds
                       (builds-by-system-excluding-cross-builds
                        derivation-changes "target"))

                      (all-systems
                       (delete-duplicates
                        (append! (map car base-builds)
                                 (map car target-builds))))

                      (categorised-base-builds-by-system
                       (categorise-builds all-systems base-builds))
                      (categorised-target-builds-by-system
                       (categorise-builds all-systems target-builds)))

                 (if (null? target-builds)
                     `((tr
                        (td (@ (colspan 7))
                            "No package derivation changes")))
                     (map
                      (match-lambda
                        ((system . categorised-target-builds)
                         (let ((categorised-base-builds
                                (assoc-ref categorised-base-builds-by-system
                                           system))
                               (highlighed-common
                                " "))
                           (define (count side status)
                             (length
                              (assoc-ref
                               (if (eq? side 'base)
                                   categorised-base-builds
                                   categorised-target-builds)
                               status)))

                           `(tr
                             (td (@ (class "monospace")) ,system)
                             ,@(map (lambda (status)
                                      `(td ,(count 'base status)))
                                    '(succeeding failing unknown))
                             (td ,@(if (and (>= (count 'target 'succeeding)
                                                (count 'base 'succeeding))
                                            (> (count 'target 'succeeding)
                                               0))
                                       `((@ (class "good")))
                                       '())
                                 ,(count 'target 'succeeding))
                             ,(if (> (count 'target 'failing)
                                     (count 'base 'failing))
                                  `(td (@ (class "bad"))
                                       (a ;; (@ (href ,(package-derivations-comparison-link
                                          ;;            system
                                          ;;            #:build-change "broken")))
                                          ,(count 'target 'failing)))
                                  `(td ,(count 'target 'failing)))
                             ,(if (> (count 'target 'unknown)
                                     (count 'base 'unknown))
                                  `(td (@ (class "bad"))
                                       (a ;; (@ (href ,(package-derivations-comparison-link
                                          ;;            system
                                          ;;            #:build-change "unknown")))
                                          ,(count 'target 'unknown)))
                                  `(td ,(count 'target 'unknown)))
                             (td (a ;; (@ (href
                                    ;;     ,(package-derivations-comparison-link system)))
                                    "View comparison"))))))
                      (sort
                       categorised-target-builds-by-system
                       (lambda (a b)
                         (< (or (list-index
                                 (lambda (s)
                                   (string=? (car a) s))
                                 %systems-to-submit-builds-for)
                                10)
                            (or (list-index
                                 (lambda (s)
                                   (string=? (car b) s))
                                 %systems-to-submit-builds-for)
                                10)))))))
               '((tr
                  (td (@ (colspan 7))
                      "Comparison unavailable")))))))))))