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

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

Rearrange rules so that TYPE works only on elements and not on attribs

File size: 6.0 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
160     ,@universal-conversion-rules)
161    )
162  )
163
164)
Note: See TracBrowser for help on using the repository browser.