(define-module (guix-qa-frontpage view issue)
  #: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 (issue-view))

(define (issue-view issue-number series derivation-changes
                    change-details comparison-details)

  (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 comparison-link
    (let ((revisions
           (assoc-ref change-details "revisions")))
      (simple-format #f "https://data.qa.guix.gnu.org/compare?base_commit=~A&target_commit=~A"
                     (assoc-ref (assoc-ref revisions "base")
                                "commit")
                     (assoc-ref (assoc-ref revisions "target")
                                "commit"))))

  (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)
      (fold
       (lambda (build result)
         (let ((package (assoc-ref build "package")))
           `((,package . ,(cons
                           build
                           (or
                            (and=> (find (match-lambda
                                           ((p . _)
                                            (package-eq? p package)))
                                         result)
                                   cdr)
                            '())))
             ,@(remove
                (match-lambda
                  ((p . _)
                   (package-eq? p package)))
                result))))
       '()
       builds))

    (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 "Issue ~A" issue-number)
   #:head
   '((style "
td.good {
  padding: 0.05rem 0.65rem;
  font-weight: bold;

  border: 0.3rem dashed green;
}

td.bad {
  padding: 0.05rem 0.65rem;
  font-weight: bold;

  border: 0.3rem dashed red;
}
"))
   #:body
   `((main
      (div
       (@ (class "large-screen-float-right"))
       (h3 "Links")
       (ul
        (li
         (a (@ (href ,(simple-format #f "https://issues.guix.gnu.org/~A"
                                     issue-number)))
            "View issue on issues.guix.gnu.org"))
        (li
         (a (@ (href ,(assoc-ref series "web_url")))
            "View series on Patchwork"))
        (li
         (a (@ (href ,comparison-link))
            "View Guix Data Service comparison"))))

      (h2 ,(assoc-ref series "name"))

      (ul
       ,@(map
          (lambda (patch)
            `(li ,(assoc-ref patch "name")))
          (assoc-ref series "patches")))

      (div
       (table
        (thead
         (tr
          (th "Change")
          (th "Linter")
          (th "Message")))
        (tbody
         ,@(if comparison-details
               (if (eq? (vector-length (assoc-ref comparison-details "lint_warnings"))
                        0)
                   `((tr
                      (td (@ (colspan 3))
                          "No lint warning changes")))
                   (append-map
                    (lambda (package-warnings)
                      (map
                       (lambda (warning)
                         `(tr
                           (td ,(assoc-ref warning "change"))
                           (td ,@(let ((checker (assoc-ref warning "checker")))
                                   `((span (@ (class "monospace")
                                              (style "display: block;"))
                                           ,(assoc-ref checker "name"))
                                     (p (@ (style "font-size: small;"))
                                        ,(assoc-ref checker "description")))))
                           (td ,(assoc-ref warning "message"))))
                       (vector->list
                        (assoc-ref package-warnings "warnings"))))
                    (vector->list
                     (assoc-ref comparison-details "lint_warnings"))))
               '((tr
                  (td (@ (colspan 3))
                      "Comparison unavailable")))))))

      (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 comparison-details
               (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")))))))))))