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

Last change on this file since 15427 was 15427, checked in by sjamaan, 12 years ago

Make nowiki work again

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