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

Last change on this file since 15372 was 15372, checked in by Ivan Raikov, 11 years ago

additions to the sxml rendering parts of qwiki

File size: 5.5 KB
Line 
1;;
2;; qwiki-sxml - SXML rules and tools for qwiki
3;;
4;; Copyright (c) 2009 Peter Bex
5;;
6;;  Redistribution and use in source and binary forms, with or without
7;;  modification, are permitted provided that the following conditions
8;;  are met:
9;;
10;;  - Redistributions of source code must retain the above copyright
11;;  notice, this list of conditions and the following disclaimer.
12;;
13;;  - Redistributions in binary form must reproduce the above
14;;  copyright notice, this list of conditions and the following
15;;  disclaimer in the documentation and/or other materials provided
16;;  with the distribution.
17;;
18;;  - Neither name of the copyright holders nor the names of its
19;;  contributors may be used to endorse or promote products derived
20;;  from this software without specific prior written permission.
21;;
22;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE
23;;  CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
24;;  INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
25;;  MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
26;;  DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR THE
27;;  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
28;;  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
29;;  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
30;;  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
31;;  AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
32;;  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
33;;  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
34;;  POSSIBILITY OF SUCH DAMAGE.
35
36(provide 'qwiki-sxml)
37
38(module qwiki-sxml
39  (qwiki-html-transformation-rules)
40
41(import chicken scheme)
42
43(use posix srfi-1 srfi-13 data-structures)
44(use sxpath-lolevel sxml-transforms doctype uri-generic)
45
46
47(define nl (list->string (list #\newline)))
48
49(define lookup-def 
50  (lambda (k lst . rest)
51    (let-optionals rest ((default #f))
52      (alist-ref k lst eq? default))))
53
54
55(define (qwiki-make-html-header head-parms)
56  `(head
57    ,nl (title ,(or (lookup-def 'title head-parms) "qwiki"))
58    ,nl (meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8")))
59    ,nl (meta (@ (http-equiv "Content-Style-Type") (content "text/css")))
60    ,nl ,(let ((style  (lookup-def 'style head-parms))
61               (print-style  (lookup-def 'print-style head-parms)))
62           (list (if style `(link (@ (rel "stylesheet") (type "text/css") (href ,style))) '())
63                 (if print-style `(link (@ (rel "stylesheet") (type "text/css") 
64                                           (media "print")  (href ,print-style))) '())))
65    ,nl
66    ,(zip
67      (map
68       (lambda (key)
69         (let ((val (lookup-def key head-parms )))
70           (and val
71                `(meta (@ (name ,(symbol->string key)) (content ,val))))))
72       '(description Author keywords
73                     Date-Revision-yyyymmdd Date-Creation-yyyymmdd))
74      (circular-list nl))
75    ,nl
76    (page-specific-links)))
77
78(define qwiki-html-transformation-rules
79
80  `((wiki-page
81     . ,(lambda (tag . elems)
82          (list
83           xhtml-1.0-strict
84           "<html>" nl
85           elems
86           "</html>" nl)))
87                       
88    (Header
89     *macro*
90     . ,(lambda (tag . headers)
91          (qwiki-make-html-header headers)))
92
93    (Section
94     *macro*
95     . ,(lambda (tag level head-word . elems)
96          `((n_) (a (@ (name ,head-word)) (n_))
97            (,(string->symbol (string-append "h" (number->string level)))
98             ,head-word ,elems))))
99
100#|    TODO: figure out how to pass the content for rescanning
101
102    (TOC        ;; Re-scan the content for "Section" tags and generate
103     . ,(lambda (tag . rest)    ;; the table of contents
104          (let ((sections
105                 (pre-post-order Content
106                                 `(
107                                   (Section     ;; (Section level "content ...")
108                                    ((*text* . ,(lambda (tag str) str)))
109                                    . ,(lambda (tag level head-word . elems)
110                                         (list "<li><a href=\"#" head-word
111                                               "\">" head-word elems "</a>" nl ))
112                                    )
113                                   (*default*
114                                    . ,(lambda (tag . elems) elems))
115                                   
116                                   (*text* . ,(lambda (trigger str) (list)))))))
117            (list "<div id=\"toc\">"
118                  "<ul>"
119                  sections
120                  "</ul></div>" nl))))
121|#
122
123    (special
124     *macro*
125     . ,(lambda (tag name arg)
126          `(,(string->symbol (string-upcase (symbol->string name))) ,arg)))
127         
128
129    (nowiki
130     *macro*
131     . ,(lambda (tag . lines)
132          `(pre ,@(map (lambda (line) (list "     " line nl))
133                       lines))))
134    (type
135     *macro*
136     . ,(lambda (tag . terms)
137          `(tt ,@terms)))
138
139    (url *macro* . ,(lambda (tag href . contents)
140                      `(a (@ (href ,href))
141                          ,(if (pair? contents) contents
142                               href))))
143
144   
145    ;; Maybe this should be done in multiple steps to make it more "hookable"
146    (history
147     *macro* . ,(lambda (history items)
148                  `(table
149                    (tr (th "revision")
150                        (th "author")
151                        (th "date")
152                        (th "description"))
153                    ,@(map (lambda (item)
154                             `(tr (td (url ,(string-append
155                                             "?action=show&rev="
156                                             (number->string (car item)))
157                                           ,(car item)))
158                                  (td ,(cadr item))
159                                  (td ,(time->string (caddr item)))
160                                  (td ,(cadddr item))))
161                           items))))
162    (page-specific-links
163     *macro* . ,(lambda _
164                  `(ul (@ (class "page-specific-links"))
165                       (li (url "?action=show" "show"))
166                       (li (url "?action=edit" "edit"))
167                       (li (url "?action=history" "history")))))
168
169    ))
170
171)
Note: See TracBrowser for help on using the repository browser.