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

Last change on this file since 15375 was 15375, checked in by Ivan Raikov, 12 years ago

factored out the qwiki-nowiki extension

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
40  (qwiki-html-transformation-rules)
41
42(import chicken scheme)
43
44(use posix srfi-1 srfi-13 data-structures)
45(use sxpath-lolevel sxml-transforms doctype uri-generic)
46
47
48(define nl (list->string (list #\newline)))
49
50(define lookup-def 
51  (lambda (k lst . rest)
52    (let-optionals rest ((default #f))
53      (alist-ref k lst eq? default))))
54
55
56(define (qwiki-make-html-header head-parms)
57  `(head
58    ,nl (title ,(or (lookup-def 'title head-parms) "qwiki"))
59    ,nl (meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8")))
60    ,nl (meta (@ (http-equiv "Content-Style-Type") (content "text/css")))
61    ,nl ,(let ((style  (lookup-def 'style head-parms))
62               (print-style  (lookup-def 'print-style head-parms)))
63           (list (if style `(link (@ (rel "stylesheet") (type "text/css") (href ,style))) '())
64                 (if print-style `(link (@ (rel "stylesheet") (type "text/css") 
65                                           (media "print")  (href ,print-style))) '())))
66    ,nl
67    ,(zip
68      (map
69       (lambda (key)
70         (let ((val (lookup-def key head-parms )))
71           (and val
72                `(meta (@ (name ,(symbol->string key)) (content ,val))))))
73       '(description Author keywords
74                     Date-Revision-yyyymmdd Date-Creation-yyyymmdd))
75      (circular-list nl))
76    ,nl))
77
78(define qwiki-html-transformation-rules
79
80  `(
81
82    ,@universal-conversion-rules
83
84    (wiki-page
85     . ,(lambda (tag . elems)
86          (list
87           xhtml-1.0-strict
88           "<html>" nl
89           elems
90           "</html>" nl)))
91
92    (Header
93     *macro*
94     . ,(lambda (tag . headers)
95          (qwiki-make-html-header headers)))
96
97    (Section
98     *macro*
99     . ,(lambda (tag level head-word . elems)
100          `((n_) (a (@ (name ,head-word)) (n_))
101            (,(string->symbol (string-append "h" (number->string level)))
102             ,head-word ,elems))))
103
104#|    TODO: figure out how to pass the content for rescanning
105
106    (TOC        ;; Re-scan the content for "Section" tags and generate
107     . ,(lambda (tag . rest)    ;; the table of contents
108          (let ((sections
109                 (pre-post-order Content
110                                 `(
111                                   (Section     ;; (Section level "content ...")
112                                    ((*text* . ,(lambda (tag str) str)))
113                                    . ,(lambda (tag level head-word . elems)
114                                         (list "<li><a href=\"#" head-word
115                                               "\">" head-word elems "</a>" nl ))
116                                    )
117                                   (*default*
118                                    . ,(lambda (tag . elems) elems))
119                                   
120                                   (*text* . ,(lambda (trigger str) (list)))))))
121            (list "<div id=\"toc\">"
122                  "<ul>"
123                  sections
124                  "</ul></div>" nl))))
125|#
126    (TOC . ,(lambda (tag rest) (list)))
127
128    (special
129     *macro*
130     . ,(lambda (tag name arg)
131          `(,(string->symbol (string-upcase (symbol->string name))) ,arg)))
132         
133    (type
134     *macro*
135     . ,(lambda (tag . terms)
136          `(tt ,@terms)))
137
138    (url *macro* . ,(lambda (tag href . contents)
139                      `(a (@ (href ,href))
140                          ,(if (pair? contents) contents
141                               href))))
142
143   
144    ;; Maybe this should be done in multiple steps to make it more "hookable"
145    (history
146     *macro* . ,(lambda (history items)
147                  `(table
148                    (tr (th "revision")
149                        (th "author")
150                        (th "date")
151                        (th "description"))
152                    ,@(map (lambda (item)
153                             `(tr (td (url ,(string-append
154                                             "?action=show&rev="
155                                             (number->string (car item)))
156                                           ,(car item)))
157                                  (td ,(cadr item))
158                                  (td ,(time->string (caddr item)))
159                                  (td ,(cadddr item))))
160                           items))))
161    (page-specific-links
162     *macro* . ,(lambda _
163                  `(ul (@ (class "page-specific-links"))
164                       (li (url "?action=show" "show"))
165                       (li (url "?action=edit" "edit"))
166                       (li (url "?action=history" "history")))))
167
168    ))
169
170)
Note: See TracBrowser for help on using the repository browser.