(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 view util)
  #:export (branch-view))

(define (branch-view branch derivation-changes)
  (define (builds-by-system-excluding-cross-builds side)
    (fold (lambda (package result)
            (fold
             (lambda (change result)
               (if (string=? (assoc-ref change "target")
                             "")
                   (let ((system (assoc-ref change "system")))
                     `((,system
                        . ,(append!
                            (map
                             (lambda (build)
                               `(,@build
                                 ("package"
                                  . (("name" . ,(assoc-ref package "name"))
                                     ("version" . ,(assoc-ref package "version"))))))
                             (vector->list (assoc-ref change "builds")))
                            (or (assoc-ref result system)
                                '())))
                       ,@(alist-delete system result)))
                   result))
             result
             (vector->list
              (assoc-ref package side))))
          '()
          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)
           ""))))

  (define (categorise-builds all-systems builds-by-system)
    (define (package-eq? a b)
      (and
       (string=?
        (assoc-ref a "name")
        (assoc-ref b "name"))
       (string=?
        (assoc-ref a "version")
        (assoc-ref b "version"))))

    (define (group-builds-by-package builds)
      (let ((result (make-hash-table)))
        (for-each
         (lambda (build)
           (let ((package (assoc-ref build "package")))
             (hash-set! result
                        package
                        (cons build
                              (or (hash-ref result package)
                                  '())))))
         builds)

        (hash-map->list cons result)))

    (define systems
      (map car builds-by-system))

    (map
     (match-lambda
       ((system . builds)
        (let ((builds-by-package
               (group-builds-by-package builds)))
          (cons
           system
           (fold
            (match-lambda*
              (((package . builds) result)
               (let* ((build-statuses
                       (map (lambda (build)
                              (assoc-ref build "status"))
                            builds))
                      (category
                       (cond
                        ((member "succeeded" build-statuses)
                         'succeeding)
                        ((and (not (member "suceeded" build-statuses))
                              (member "failed" build-statuses))
                         'failing)
                        (else
                         'unknown))))

                 `((,category . ,(cons
                                  (cons package builds)
                                  (assq-ref result category)))
                   ,@(alist-delete category result)))))
            '((succeeding . ())
              (failing . ())
              (unknown . ()))
            builds-by-package)))))

     (append builds-by-system
             (map (lambda (system)
                    (cons system '()))
                  (filter (lambda (system)
                            (not (member system systems)))
                          all-systems)))))

  (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 "base"))
                      (target-builds
                       (builds-by-system-excluding-cross-builds "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")))))))))))