;; 
;; qwiki-sxml - SXML rules and tools for qwiki
;; 
;; Copyright (c) 2009-2017 Peter Bex and Ivan Raikov
;;
;;  Redistribution and use in source and binary forms, with or without
;;  modification, are permitted provided that the following conditions
;;  are met:
;; 
;;  - Redistributions of source code must retain the above copyright
;;  notice, this list of conditions and the following disclaimer.
;; 
;;  - Redistributions in binary form must reproduce the above
;;  copyright notice, this list of conditions and the following
;;  disclaimer in the documentation and/or other materials provided
;;  with the distribution.
;; 
;;  - Neither name of the copyright holders nor the names of its
;;  contributors may be used to endorse or promote products derived
;;  from this software without specific prior written permission.
;; 
;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE
;;  CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
;;  INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
;;  MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;;  DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR THE
;;  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;;  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
;;  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
;;  AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
;;  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
;;  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;;  POSSIBILITY OF SUCH DAMAGE.

(module qwiki-sxml

(title-for-wiki-page
 qwiki-html-transformation-rules)

(import scheme (chicken base) (chicken irregex) (chicken condition)
        (chicken string) (chicken time posix)
        srfi-1 srfi-13 sxpath sxml-transforms html-parser colorize)

;; Try to extract a meaningful title from the page contents
;; Unfortunately, title contents aren't always correct sxml but can
;; be a list of strings, so we need to do some massaging of the content.
;; This code doesn't work for links (eg, int-link doesn't have the target
;; as an attribute but as contents. d'oh!)
(define (title-for-wiki-page page)
  (and-let* ((section ((if-car-sxpath '(// (section 1))) (cons 'root page)))
             (section-contents (caddr section)))
    (if (string? section-contents)
        section-contents
        (string-concatenate
         (append-map (lambda (x)
                       (if (string? x)
                           (list x)
                           ((sxpath '(// *text*)) x)))
                     section-contents)))))

(define (lookup-def k lst . rest)
  (let-optionals rest ((default #f))
    (alist-ref k lst eq? default)))

(define (make-html-header head-params)
  `(head
    ,@(let ((title (lookup-def 'title head-params)))
        (if title `((title ,title)) '()))
    (meta (@ (http-equiv "Content-Style-Type") (content "text/css")))
    (meta (@ (http-equiv "Content-Type") 
             (content ,(lookup-def 'Content-Type head-params 
                                   "text/html; charset=UTF-8"))))
    ,(let ((style  (lookup-def 'style head-params))
           (print-style  (lookup-def 'print-style head-params))
           (canonical (lookup-def 'canonical head-params)))
       (list (if style `(link (@ (rel "stylesheet") (type "text/css") (href ,style))) '())
             (if print-style `(link (@ (rel "stylesheet") (type "text/css") 
                                       (media "print")  (href ,print-style))) '())
             (if canonical `(link (@ (rel "canonical") (href ,canonical))) '())))
    ;; Remove already processed head parameters, inserting only unprocessed ones
    ,@(remove (lambda (param)
                (member (car param) '(title style print-style canonical
                                            new-file existing-file
                                            read-only read-write)))
              head-params)))

(define (internal-link r)
  (pre-post-order* 
   r
   `((*default* . ,(lambda (tag . elems) elems))
     (*text* . ,(lambda (trigger str) 
                  (let ((str (string-downcase str)))
                    (fold (lambda (regex/subst str)
                            (irregex-replace/all (car regex/subst) str (cdr regex/subst)))
                          str
                          '(("^[^a-z]+" . "")
                            ("[^a-z0-9_ \t-]" . "")
                            ("[ \t]+" . "-")))))))))

(define (qwiki-html-transformation-rules content)
  `(((wiki-page 
      *macro*
      . ,(lambda (tag elems)
           `(html:begin . ,elems)))

     ;; Maybe this should be done in multiple steps to make it more "hookable"
     (history
      *macro* 
      . ,(lambda (tag elements)
           (let* ((items-per-page (car elements))
                  (path (cadr elements))
                  (start-revisions (caddr elements))
                  (all-items (cdddr elements))
                  (items (if (> (length all-items) items-per-page)
                             (take all-items items-per-page)
                             all-items))
                  (first-item-on-next-page
                   (and (> (length all-items) items-per-page)
                        (list-ref all-items items-per-page))))
             `(div
               (h3 "Edit history for page: " ,path)
               (form (@ (method "get") (action ""))
                     (input (@ (type "hidden") (name "action")
                               (value "diff")))
                     (table
                      (tr (th "revision")
                          (th "author")
                          (th "date")
                          (th "description")
                          (th "r1")
                          (th "r2"))
                      ,@(map (lambda (item)
                               ;; TODO: The nofollow should really apply
                               ;; to the entire page instead of each
                               ;; individual link.
                               `(tr (td (a (@ (rel "nofollow")
                                              (href ,(string-append
                                                      "?action=show&rev="
                                                      (number->string (car item)))))
                                           ,(car item)))
                                    (td ,(cadr item))
                                    (td ,(time->string (caddr item)))
                                    (td ,(cadddr item))
                                    (td (input (@ (type "radio")
                                                  (name "rev1")
                                                  (value ,(car item)))))
                                    (td (input (@ (type "radio")
                                                  (name "rev2")
                                                  (value ,(car item)))))))
                             items))
                     (input (@ (type "submit")
                               (value "show diff between selected revisions")
                               (class "diff-selection"))))
               ;; Bleeeeergh
               (div (@ (class "pager"))
                    ,@(if (not (null? start-revisions))
                          `((a (@ (href "?action=history"
                                        ,(string-join
                                          (map ->string
                                               (cdr start-revisions))
                                          "&rev=" 'prefix))
                                  (class "prev-page"))
                               "prev page") " ")
                          '())
                    ,@(if first-item-on-next-page
                          (let ((revs (cons (car first-item-on-next-page)
                                            start-revisions)))
                            `((a (@ (href "?action=history"
                                          ,(string-join
                                            (map ->string revs)
                                            "&rev=" 'prefix))
                                    (class "next-page"))
                                 "next page")))
                          '()))))))

     (diff
      *macro*
      . ,(lambda (tag elems)
           ;; The diff-language class is a bit weird here, but
           ;; consistent with what we would emit in a highlight block.
           (let* ((classname "highlight diff-language diff-page")
                  (diff (handle-exceptions exn elems
                          (map (lambda (s)
                                 (cdr (html->sxml (html-colorize 'diff s))))
                               elems))))
             `(pre (@ (class ,classname)) . ,diff))))

     (wiki-content
      *macro* .
      ,(lambda (tag contents)
         `(div (@ (id "content")) . ,contents)))

     (tags
      *preorder* .
      ,(lambda (tag page-tags)
         `(ul (@ (class "tags"))
              . ,(map (lambda (tag) `(li ,tag))
                      (string-split (car page-tags))))))

     (highlight
      *macro*
      . ,(lambda (tag elems)
           (let* ((lang (car elems))
                  (classname (conc "highlight " lang "-language"))
                  (code (handle-exceptions exn
                            (cdr elems)
                          (map (lambda (s)
                                 (cdr (html->sxml (html-colorize lang s))))
                               (cdr elems)))))
             `(pre (@ (class ,classname)) . ,code))))

     (examples
      ((example
        ((init
          *macro*
          . ,(lambda (tag elems)
               `(div (@ (class "init")) (highlight scheme . ,elems))))
         (expr
          *macro*
          . ,(lambda (tag elems)
               `(div (@ (class "expression")) (highlight scheme . ,elems))))
         (input
          *macro*
          . ,(lambda (tag elems)
               `(div (@ (class "io input")) (em "input: ")
                     (highlight scheme . ,elems))))
         (output
          *macro*
          . ,(lambda (tag elems)
               `(div (@ (class "io output")) (em "output: ")
                     (highlight scheme . ,elems))))
         (result
          *macro*
          . ,(lambda (tag elems)
               `(div (@ (class "result"))
                     (span (@ (class "result-symbol")) " => ")
                     (highlight scheme . ,elems))))) ;; Or use "basic lisp" here?
        . ,(lambda (tag elems)
             `(div (@ (class "example")) . ,elems))))
      . ,(lambda (tag elems)
           `(div (@ (class "examples"))
                 (span (@ (class "examples-heading")) "Examples:") . ,elems)))

     (page-specific-links
      *macro* 
      . ,(lambda (tag elems)
           `(ul (@ (id "page-specific-links"))
                (li ,(if ((if-sxpath '(// new-file)) (cons tag elems))
                         `(span (@ (class "disabled")
                                   (title "This page doesn't exist yet"))
                                "show")
                         `(a (@ (href "?action=show")) "show")))
                (li ,(if ((if-sxpath '(// read-only)) (cons tag elems))
                         `(span (@ (class "disabled")
                                   (title "This page has been frozen. "
                                          "Only someone with direct access "
                                          "to the repository can edit it."))
                                "edit")
                         `(a (@ (href "?action=edit") (rel "nofollow")) "edit")))
                (li ,(if ((if-sxpath '(// new-file)) (cons tag elems))
                         `(span (@ (class "disabled")
                                   (title "This page doesn't exist yet"))
                                "history")
                         `(a (@ (href "?action=history")) "history"))))))

     (@ *preorder* . ,(lambda (tag elements) (cons tag elements)))

     (Header
      *preorder*
      . ,(lambda (tag headers)
           (make-html-header headers)))

     (toc ;; Re-scan the content for "section" tags and generate
      *macro*
      . ,(lambda (tag rest) ;; the table of contents
           `(div (@ (id "toc"))
                 ,rest
                 (ol ,(let find-sections ((content content))
                        (cond
                         ((not (pair? content)) '())
                         ((pair? (car content))
                          (append (find-sections (car content))
                                  (find-sections (cdr content))))
                         ((eq? (car content) 'section)
                          (let* ((level (cadr content))
                                 (head-word (caddr content))
                                 (href (list "#" (internal-link head-word)))
                                 (subsections (find-sections (cdddr content))))
                            (cond ((and (integer? level) head-word)
                                   `((li (a (@ (href (,href))) ,head-word)
                                         ,@(if (null? subsections)
                                               '()
                                               `((ol ,subsections))))))
                                  (else
                                   (error 'html-transformation-rules
                                          "section elements must be of the form (section level head-word . contents)")))))
                         (else (find-sections (cdr content)))))))))

     (section
      *macro*
      . ,(lambda (tag elems)
           (let* ((level (car elems))
                  (head-word (cadr elems))
                  (link (internal-link head-word))
                  (contents (cddr elems)))
             (cond ((and (integer? level) head-word)
                    `((a (@ (href ,@(list "#" link)))
                         (,(string->symbol (string-append "h" (number->string level)))
                          (@ (id ,link))
                          ,head-word)) . ,contents))
                   (else
                    (error 'html-transformation-rules
                           (conc "section elements must be of the form (section level head-word . contents), got " elems)))))))

     (section*
      *macro*
      . ,(lambda (tag elems)
           (let ((level (car elems))
                 (head-word (cadr elems))
                 (contents (cddr elems)))
             (cond ((and (integer? level) head-word)
                    `((,(string->symbol (string-append "h" (number->string level)))
                       ,head-word ) . ,contents))
                   (else
                    (error 'html-transformation-rules
                           (conc "section elements must be of the form (section level head-word . contents), got " elems)))))))

     (def
      ((sig . ,(lambda (tag types)
                 (map (lambda (spec)
                        `(span (@ (class ,(conc "definition " (car spec))))
                               (em "[" ,(symbol->string (car spec)) "]")
                               " " (tt ,@(cdr spec)) (br)))
                      types))))
      . ,(lambda (tag elems) elems))

     (pre
      . ,(lambda (tag elems)
           `(pre (tt . ,elems))))

     (image-link
      *macro*
      . ,(lambda (tag elems)
           `(img (@ (src ,(car elems)) . ,(if (null? (cdr elems))
                                              '()
                                              `((alt ,(cadr elems))
                                                (title ,(cadr elems))))))))

     (int-link
      *macro*
      . ,(lambda (tag elems)
           ;; Normalize links so people can refer to sections by their proper name
           (let* ((parts (string-split (car elems) "#" #t))
                  (nparts (intersperse
                           (cons (car parts) (internal-link (cdr parts)))
                           "#")))
             `(a (@ (href ,@nparts) (class "internal"))
                 ,(if (null? (cdr elems)) (car elems) (cadr elems))))))

     (link
      *macro*
      . ,(lambda (tag elems)
           `(a (@ (href ,(car elems)) (class "external"))
               ,(if (null? (cdr elems)) (car elems) (cadr elems)))))

     ,@alist-conv-rules*)

    ((html:begin
      . ,(lambda (tag elems)
           (list "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"
                 "<html xmlns=\"http://www.w3.org/1999/xhtml\">"
                 elems
                 "</html>")))

     (verbatim
      *preorder*
      . ,(lambda (tag elems)
           elems))

     ,@universal-conversion-rules*)))

)