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

Last change on this file since 15383 was 15383, checked in by Ivan Raikov, 10 years ago

added table of contents functionality to qwiki

File size: 5.4 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 content)
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) ,nl
103            )))
104
105    (TOC        ;; Re-scan the content for "Section" tags and generate
106     . ,(lambda (tag . rest)    ;; the table of contents
107          (let ((sections
108                 (pre-post-order content
109                                 `(
110                                   (Section     ;; (Section level "content ...")
111                                    ((*text* . ,(lambda (tag str) str)))
112                                    . ,(lambda (tag level head-word . elems)
113                                         (list "<li><a href=\"#" head-word
114                                               "\">" head-word elems "</a>" nl ))
115                                    )
116                                   (*default*
117                                    . ,(lambda (tag . elems) elems))
118                                   
119                                   (*text* . ,(lambda (trigger str) (list)))))))
120            (list "<div id=\"toc\">" 
121                  "<ul>"
122                  sections 
123                  "</ul></div>" nl))))
124
125    (special
126     *macro*
127     . ,(lambda (tag name arg)
128          `(,(string->symbol (string-upcase (symbol->string name))) ,arg)))
129         
130    (type
131     *macro*
132     . ,(lambda (tag . terms)
133          `(tt ,@terms)))
134
135    (url *macro* . ,(lambda (tag href . contents)
136                      `(a (@ (href ,href))
137                          ,(if (pair? contents) contents
138                               href))))
139
140   
141    ;; Maybe this should be done in multiple steps to make it more "hookable"
142    (history
143     *macro* . ,(lambda (history items)
144                  `(table
145                    (tr (th "revision")
146                        (th "author")
147                        (th "date")
148                        (th "description"))
149                    ,@(map (lambda (item)
150                             `(tr (td (url ,(string-append
151                                             "?action=show&rev="
152                                             (number->string (car item)))
153                                           ,(car item)))
154                                  (td ,(cadr item))
155                                  (td ,(time->string (caddr item)))
156                                  (td ,(cadddr item))))
157                           items))))
158    (page-specific-links
159     *macro* . ,(lambda _
160                  `(ul (@ (class "page-specific-links"))
161                       (li (url "?action=show" "show"))
162                       (li (url "?action=edit" "edit"))
163                       (li (url "?action=history" "history")))))
164
165    ))
166
167)
Note: See TracBrowser for help on using the repository browser.