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

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

some more modifications to content rendering in qwiki

File size: 5.7 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  `(
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    (nowiki
129      ((*text*       ; local override for nowiki text
130        . ,(lambda (tag . str) str)))
131     . ,(lambda (tag . lines)
132          `(,@(map (lambda (line) (list "     " line nl)) lines)
133            )))
134
135    (special
136     *macro*
137     . ,(lambda (tag name arg)
138          `(,(string->symbol (string-upcase (symbol->string name))) ,arg)))
139         
140    (type
141     *macro*
142     . ,(lambda (tag . terms)
143          `(tt ,@terms)))
144
145    (url *macro* . ,(lambda (tag href . contents)
146                      `(a (@ (href ,href))
147                          ,(if (pair? contents) contents
148                               href))))
149
150   
151    ;; Maybe this should be done in multiple steps to make it more "hookable"
152    (history
153     *macro* . ,(lambda (history items)
154                  `(table
155                    (tr (th "revision")
156                        (th "author")
157                        (th "date")
158                        (th "description"))
159                    ,@(map (lambda (item)
160                             `(tr (td (url ,(string-append
161                                             "?action=show&rev="
162                                             (number->string (car item)))
163                                           ,(car item)))
164                                  (td ,(cadr item))
165                                  (td ,(time->string (caddr item)))
166                                  (td ,(cadddr item))))
167                           items))))
168    (page-specific-links
169     *macro* . ,(lambda _
170                  `(ul (@ (class "page-specific-links"))
171                       (li (url "?action=show" "show"))
172                       (li (url "?action=edit" "edit"))
173                       (li (url "?action=history" "history")))))
174
175    ))
176
177)
Note: See TracBrowser for help on using the repository browser.