source: project/release/4/qwiki/trunk/qwiki-sxml.scm @ 15426

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

  (qwiki-html-transformation-rules)

(import chicken scheme)

(use posix srfi-1 srfi-13 data-structures)
(use sxpath-lolevel sxml-transforms doctype uri-generic)


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


(define (qwiki-make-html-header head-parms)
  `(head
    (title ,(or (lookup-def 'title head-parms) "qwiki"))
    (meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8")))
    (meta (@ (http-equiv "Content-Style-Type") (content "text/css")))
    ,(let ((style  (lookup-def 'style head-parms))
           (print-style  (lookup-def 'print-style head-parms)))
       (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))) '())))
    ,(map
      (lambda (key)
        (let ((val (lookup-def key head-parms )))
          (and val
               `(meta (@ (name ,(symbol->string key)) (content ,val))))))
      '(description Author keywords
                    Date-Revision-yyyymmdd Date-Creation-yyyymmdd))))

(define (qwiki-html-transformation-rules content)
  `((
     (@ *preorder* . ,(lambda element element))
     
     (Header
      *macro*
      . ,(lambda (tag . headers)
           (qwiki-make-html-header headers)))

     (Section
      *macro*
      . ,(lambda (tag level head-word . elems)
           `((n_) (a (@ (name ,head-word)) (n_))
             (,(string->symbol (string-append "h" (number->string level)))
              ,head-word ,elems) 
             )))

     (special
      *macro*
      . ,(lambda (tag name arg)
           `(,(string->symbol (string-upcase (symbol->string name))) ,arg)))
          
     (type
      *macro*
      . ,(lambda (tag . terms)
           `(tt ,@terms)))

     (url *macro* . ,(lambda (tag href . contents)
                       `(a (@ (href ,href))
                           ,(if (pair? contents) contents
                                href))))

    
     ;; Maybe this should be done in multiple steps to make it more "hookable"
     (history
      *macro* . ,(lambda (history items)
                   `(table
                     (tr (th "revision")
                         (th "author")
                         (th "date")
                         (th "description"))
                     ,@(map (lambda (item)
                              `(tr (td (url ,(string-append
                                              "?action=show&rev="
                                              (number->string (car item)))
                                            ,(car item)))
                                   (td ,(cadr item))
                                   (td ,(time->string (caddr item)))
                                   (td ,(cadddr item))))
                            items))))
     (page-specific-links
      *macro* . ,(lambda _
                   `(ul (@ (class "page-specific-links"))
                        (li (url "?action=show" "show"))
                        (li (url "?action=edit" "edit"))
                        (li (url "?action=history" "history")))))
     ,@alist-conv-rules
     )
    (
     (wiki-page
      . ,(lambda (tag . elems)
           (list
            xhtml-1.0-strict
            "<html>"
            elems
            "</html>")))

     (TOC ;; Re-scan the content for "Section" tags and generate
      . ,(lambda (tag . rest) ;; the table of contents
           (let ((sections
                  (pre-post-order content
                                  `(
                                    (Section ;; (Section level "content ...")
                                     ((*text* . ,(lambda (tag str) str)))
                                     . ,(lambda (tag level head-word . elems)
                                          (list "<li><a href=\"#" head-word
                                                "\">" head-word elems "</a>"))
                                     )
                                    (*default*
                                     . ,(lambda (tag . elems) elems))
                                   
                                    (*text* . ,(lambda (trigger str) (list)))))))
             (list "<div id=\"toc\">" 
                   "<ul>"
                   sections 
                   "</ul></div>"))))


     ,@universal-conversion-rules)
    )
  )

)