;;; tissue --- Text based issue tracker
;;; Copyright © 2022, 2023 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of tissue.
;;;
;;; tissue is free software: you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; tissue is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with tissue.  If not, see <https://www.gnu.org/licenses/>.

(define-module (tissue web themes default)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:use-module (oop goops)
  #:use-module (web uri)
  #:use-module (xapian xapian)
  #:use-module (tissue commit)
  #:use-module (tissue document)
  #:use-module (tissue file-document)
  #:use-module (tissue issue)
  #:use-module (tissue utils)
  #:use-module (tissue web themes)
  #:export (default-theme
            <search-page-head>
            <search-page-header>
            <search-page-form>
            <search-page-result>
            <search-page-footer>))

(define-class <search-page-head> ())
(define-class <search-page-header> ())
(define-class <search-page-form> ())
(define-class <search-page-result> ())
(define-class <search-page-footer> ())

(define %css
  "
body {
    max-width: 1000px;
    margin: 0 auto;
}

form { text-align: center; }
.search-filter {
    background-color: gray;
    color: white;
    padding: 0 0.2em;
}

.search-results-statistics {
    list-style: none;
    padding: 0;
}
.search-results-statistics li {
    display: inline;
    margin: 0.5em;
}
.search-results-statistics a { color: blue; }
.current-search-type { font-weight: bold; }

.search-results { padding: 0; }
.search-result {
    list-style-type: none;
    padding: 0.5em;
}
.search-result a { text-decoration: none; }
.document-type {
    font-variant: small-caps;
    font-weight: bold;
}
.search-result-metadata {
    color: dimgray;
    font-size: smaller;
}
.search-result-snippet { font-size: smaller; }

.tags {
    list-style-type: none;
    padding: 0;
    display: inline;
}
.tag { display: inline; }
.tag a {
    padding: 0 0.2em;
    color: white;
    background-color: blue;
    margin: auto 0.25em;
    font-size: smaller;
}
.tag-bug a { background-color: red; }
.tag-feature a { background-color: green; }
.tag-progress a, .tag-unassigned a {
    background-color: orange;
    color: black;
}
.tag-chore a {
    background-color: khaki;
    color: black;
}")

(define* (default-theme #:key (title "tissue issue tracker") css)
  "Return a generic function that renders a page using the default
theme.

@var{title} is the title to use in the head of the HTML. @var{css} is
a URI to a CSS stylesheet to link to. If it is @code{#f}, no
stylesheet is linked to."
  (add-method! render-sxml
               (make <method>
                 #:specializers (list <search-page-head> <search-page>)
                 #:procedure (make-head-renderer title css)))
  render-sxml)

(define-method (render-sxml (page <search-page>))
  "Return SXML for @var{page}, a @code{<search-page>}."
  `(html
    ,(render-sxml (make <search-page-head>) page)
    (body
     ,(render-sxml (make <search-page-header>) page)
     ,(render-sxml (make <search-page-form>) page)
     ,(render-sxml (make <search-page-result>) page)
     ,(render-sxml (make <search-page-footer>) page))))

(define (make-head-renderer title css)
  (lambda (_ page)
    `(head
      (title ,title)
      (style ,%css)
      ,@(if css
            (list `(link (@ (href ,css)
                            (rel "stylesheet")
                            (type "text/css"))))
            (list)))))

(define-method (render-sxml (header <search-page-header>) (page <search-page>))
  `(div))

(define-method (render-sxml (form <search-page-form>) (page <search-page>))
  `(div
    (form (@ (action "/search") (method "GET"))
          (input (@ (type "text")
                    (name "query")
                    (value ,(search-page-query page))
                    (placeholder "Enter search query")))
          (input (@ (type "hidden")
                    (name "type")
                    (value ,(symbol->string (search-page-type page)))))
          (input (@ (type "submit") (value "Search"))))
    (details (@ (class "search-hint"))
             (summary "Hint")
             (p "Refine your search with filters "
                ,@(append-map (lambda (filter)
                                (list `(span (@ (class "search-filter"))
                                             ,filter)
                                      ", "))
                              (list "type:issue"
                                    "type:document"
                                    "is:open"
                                    "is:closed"
                                    "title:git"
                                    "creator:mani"
                                    "lastupdater:vel"
                                    "assigned:muthu"
                                    "tag:feature-request"))
                "etc. Optionally, combine search terms with boolean operators "
                (span (@ (class "search-filter"))
                      "AND")
                " and "
                (span (@ (class "search-filter"))
                      "OR")
                ". See " (a (@ (href "https://xapian.org/docs/queryparser.html"))
                            "Xapian::QueryParser Syntax")
                " for detailed documentation."))))

(define-method (render-sxml (result <search-page-result>) (page <search-page>))
  (define (search-result-statistic search-type format-string matches)
    `(li (a (@ (href ,(string-append
                       (uri-path (search-page-uri page))
                       "?"
                       (query-string
                        (acons "type" (symbol->string search-type)
                               (alist-delete "type"
                                             (query-parameters
                                              (uri-query (search-page-uri page))))))))
               ,@(if (eq? search-type (search-page-type page))
                     '((class "current-search-type"))
                     '()))
            ,(format #f format-string matches))))
  
  `(div
    (ul (@ (class "search-results-statistics"))
        ,(search-result-statistic 'all "~a All" (search-page-matches page))
        ,(search-result-statistic 'open-issue "~a open issues" (search-page-matched-open-issues page))
        ,(search-result-statistic 'closed-issue "~a closed issues" (search-page-matched-closed-issues page))
        ,(search-result-statistic 'document "~a documents" (search-page-matched-documents page))
        ,(search-result-statistic 'commit "~a commits" (search-page-matched-commits page)))
    (ul (@ (class "search-results"))
        ,@(reverse
           (mset-fold (lambda (item result)
                        (cons (render-sxml
                               (call-with-input-string (document-data (mset-item-document item))
                                 (compose scm->object read))
                               page)
                              result))
                      '()
                      (search-page-mset page))))))

(define-method (render-sxml (document <file-document>) (page <search-page>))
  `(li (@ (class "search-result search-result-document"))
       (a (@ (href ,(document-web-uri document))
             (class "search-result-title"))
          ,(document-title document))
       (div (@ (class "search-result-metadata"))
            (span (@ (class ,(string-append "document-type file-document-type")))
                  "document")
            ,(string-append
              (format #f " created ~a by ~a"
                      (human-date-string (file-document-created-date document))
                      (file-document-creator document))
              (if (> (length (file-document-commits document))
                     1)
                  (format #f ", last updated ~a by ~a"
                          (human-date-string (file-document-last-updated-date document))
                          (file-document-last-updater document))
                  "")))
       ,@(let ((snippet (document-sxml-snippet document (search-page-mset page))))
           (if snippet
               (list `(div (@ (class "search-result-snippet"))
                           ,@snippet))
               (list)))))

(define (sanitize-string str)
  "Downcase STR and replace spaces with hyphens."
  (string-map (lambda (c)
                (case c
                  ((#\space) #\-)
                  (else c)))
              (string-downcase str)))

(define-method (render-sxml (issue <issue>) (page <search-page>))
  `(li (@ (class ,(string-append "search-result search-result-issue "
                                 (if (issue-open? issue)
                                     "search-result-open-issue"
                                     "search-result-closed-issue"))))
       (a (@ (href ,(document-web-uri issue))
             (class "search-result-title"))
          ,(document-title issue))
       (ul (@ (class "tags"))
           ,@(map (lambda (tag)
                    (let ((words (string-split tag (char-set #\- #\space))))
                      `(li (@ (class
                                ,(string-append "tag"
                                                (string-append " tag-" (sanitize-string tag))
                                                (if (not (null? (lset-intersection
                                                                 string=? words
                                                                 (list "bug" "critical"))))
                                                    " tag-bug"
                                                    "")
                                                (if (not (null? (lset-intersection
                                                                 string=? words
                                                                 (list "progress"))))
                                                    " tag-progress"
                                                    "")
                                                (if (not (null? (lset-intersection
                                                                 string=? words
                                                                 (list "chore"))))
                                                    " tag-chore"
                                                    "")
                                                (if (not (null? (lset-intersection
                                                                 string=? words
                                                                 (list "enhancement" "feature"))))
                                                    " tag-feature"
                                                    ""))))
                           (a (@ (href ,(string-append
                                         "/search?query="
                                         (uri-encode
                                          ;; Quote tag if it has spaces.
                                          (string-append "tag:"
                                                         (if (string-any #\space tag)
                                                             (string-append "\"" tag "\"")
                                                             tag))))))
                              ,tag))))
                  (issue-keywords issue)))
       (div (@ (class "search-result-metadata"))
            (span (@ (class ,(string-append "document-type issue-document-type "
                                            (if (issue-open? issue)
                                                "open-issue-document-type"
                                                "closed-issue-document-type"))))
                  ,(if (issue-open? issue)
                       "issue"
                       "✓ issue"))
            ,(string-append
              (format #f " opened ~a by ~a"
                      (human-date-string (file-document-created-date issue))
                      (file-document-creator issue))
              (if (> (length (file-document-commits issue))
                     1)
                  (format #f ", last updated ~a by ~a"
                          (human-date-string (file-document-last-updated-date issue))
                          (file-document-last-updater issue))
                  "")
              (if (zero? (issue-tasks issue))
                  ""
                  (format #f "; ~a of ~a tasks done"
                          (issue-completed-tasks issue)
                          (issue-tasks issue)))))
       ,@(let ((snippet (document-sxml-snippet issue (search-page-mset page))))
           (if snippet
               (list `(div (@ (class "search-result-snippet"))
                           ,@snippet))
               (list)))))

(define-method (render-sxml (commit <commit>) (page <search-page>))
  `(li (@ (class ,(string-append "search-result search-result-commit")))
       (a (@ (href ,(document-web-uri commit))
             (class "search-result-title"))
          ,(document-title commit))
       (div (@ (class "search-result-metadata"))
            (span (@ (class ,(string-append "document-type commit-document-type")))
                  "commit")
            ,(string-append
              (format #f " authored ~a by ~a"
                      (human-date-string (doc:commit-author-date commit))
                      (doc:commit-author commit))))
       ,@(let ((snippet (document-sxml-snippet commit (search-page-mset page))))
           (if snippet
               (list `(div (@ (class "search-result-snippet"))
                           ,@snippet))
               (list)))))

(define-method (render-sxml (footer <search-page-footer>) (page <search-page>))
  `(div))