;; 
;; qwiki-sxml - SXML rules and tools for qwiki
;; 
;; Copyright (c) 2009-2012 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.

(provide 'qwiki-sxml)

(module qwiki-sxml

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

(import chicken scheme)

(use posix srfi-1 srfi-13 data-structures extras multidoc)
(use sxml-transforms doctype uri-generic sxpath colorize html-parser)

;; 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)))))

;;;;
;;;;  HTML stylesheet
;;;; 

(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 items)
	   `(table
	     (tr (th "revision")
		 (th "author")
		 (th "date")
		 (th "description"))
	     ,@(map (lambda (item)
                      ;; XXX nofollow should really apply to the entire page
                      ;; instead of on each individual link.  But to do that
                      ;; we need to hack multidoc.  It's time to replace
                      ;; multidoc or clean it up and start maintaining it.
		      `(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))))
		    items))))

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

     ,@alist-conv-rules*
     )
    
     ,@(html-transformation-rules content)

  ))

;;;;
;;;;  LaTeX stylesheet
;;;; 

(define nl (list->string (list #\newline)))

(define (qwiki-LaTeX-transformation-rules content)
  `(
    (
     (wiki-page
      . ,(lambda (tag elems)
	     (list
	      `(tex
		"\\documentclass[12pt]{article}" ,nl
		"\\usepackage[left=3cm]{geometry}" ,nl

		,(map (lambda (p) (LaTeX-use-package (car p) (cadr p)))
		      (LaTeX-packages)) ,nl
		     
		      "%%%%%%%%%%%%%%%%%%%%%%%%%% Textclass specific LaTeX commands." ,nl
		      " \\newenvironment{lyxcode}" ,nl
		      "   {\\begin{list}{}{" ,nl
		      "     \\raggedright" ,nl
		      "     \\setlength{\\itemsep}{-5pt}" ,nl
		      "     \\setlength{\\parsep}{-3pt}" ,nl
		      "     \\normalfont\\ttfamily}%" ,nl
		      "    \\item[]}" ,nl
		      "   {\\end{list}}" ,nl

		      "\\makeatother" ,nl
		      "\\sloppy" ,nl
	    
		      "\\newcommand{\\minitab}[2][l]{\\begin{tabular}{#1}#2\\end{tabular}}" ,nl)
	      
	      nl
	      elems
	      )))

     ;; No syntax highlighting yet, present as preformatted
     (highlight
      *macro*
      . ,(lambda (tag elems)
           ;; (highlight LANGUAGE "text" ...)
           `(pre . ,(cdr elems))))
     
     (examples
      ((example
        ((init
          *macro*
          . ,(lambda (tag elems)
               `(pre . ,elems)))
         (expr
          *macro*
          . ,(lambda (tag elems)
               `(pre . ,elems)))
         (input
          *macro*
          . ,(lambda (tag elems)
               `((em "input: ")
                 (pre . ,elems))))
         (output
          *macro*
          . ,(lambda (tag elems)
               `((em "output: ")
                 (pre . ,elems))))
         (result
          *macro*
          . ,(lambda (tag elems)
               `(pre " => " . ,elems))))
        . ,(lambda (tag elems)
             elems)))
      . ,(lambda (tag elems)
           elems))

     ,@alist-conv-rules*
     )

     ,@(LaTeX-transformation-rules content)
     ))

;;;;
;;;;  Texinfo stylesheet
;;;; 

(define nl (list->string (list #\newline)))

(define (qwiki-Texinfo-transformation-rules content)
  `(
    (
     (wiki-page
      *macro* .
      ,(lambda (tag elems) (cons 'body elems)))


     ;; No syntax highlighting yet, present as preformatted
     (highlight
      *macro*
      . ,(lambda (tag elems)
           ;; (highlight LANGUAGE "text" ...)
           `(pre . ,(cdr elems))))
     
     (examples
      ((example
        ((init
          *macro*
          . ,(lambda (tag elems)
               `(pre . ,elems)))
         (expr
          *macro*
          . ,(lambda (tag elems)
               `(pre . ,elems)))
         (input
          *macro*
          . ,(lambda (tag elems)
               `((em "input: ")
                 (pre . ,elems))))
         (output
          *macro*
          . ,(lambda (tag elems)
               `((em "output: ")
                 (pre . ,elems))))
         (result
          *macro*
          . ,(lambda (tag elems)
               `(pre " => " . ,elems)))
         (*text* . ,(lambda (tag elems) elems))
         (*default* . ,(lambda (tag elems) '())))
        . ,(lambda (tag elems)
             elems)))
      . ,(lambda (tag elems)
           elems))

     ,@alist-conv-rules
     )

     ,@(Texinfo-transformation-rules content)
     ))


)