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

Last change on this file since 32679 was 32679, checked in by sjamaan, 6 years ago

qwiki: Remove bogus "existing-file" tag, like we do for "new-file"

File size: 13.1 KB
Line 
1;;
2;; qwiki-sxml - SXML rules and tools for qwiki
3;;
4;; Copyright (c) 2009-2015 Peter Bex and Ivan Raikov
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(module qwiki-sxml
37
38(title-for-wiki-page
39 qwiki-html-transformation-rules)
40
41(import chicken scheme)
42
43(use posix srfi-1 srfi-13 data-structures extras irregex)
44(use sxml-transforms doctype uri-generic sxpath colorize html-parser)
45
46;; Try to extract a meaningful title from the page contents
47;; Unfortunately, title contents aren't always correct sxml but can
48;; be a list of strings, so we need to do some massaging of the content.
49;; This code doesn't work for links (eg, int-link doesn't have the target
50;; as an attribute but as contents. d'oh!)
51(define (title-for-wiki-page page)
52  (and-let* ((section ((if-car-sxpath '(// (section 1))) (cons 'root page)))
53             (section-contents (caddr section)))
54    (if (string? section-contents)
55        section-contents
56        (string-concatenate
57         (append-map (lambda (x)
58                       (if (string? x)
59                           (list x)
60                           ((sxpath '(// *text*)) x)))
61                     section-contents)))))
62
63(define (lookup-def k lst . rest)
64  (let-optionals rest ((default #f))
65    (alist-ref k lst eq? default)))
66
67(define (make-html-header head-params)
68  `(head
69    ,@(let ((title (lookup-def 'title head-params)))
70        (if title `((title ,title)) '()))
71    (meta (@ (http-equiv "Content-Style-Type") (content "text/css")))
72    (meta (@ (http-equiv "Content-Type") 
73             (content ,(lookup-def 'Content-Type head-params 
74                                   "text/html; charset=UTF-8"))))
75    ,(let ((style  (lookup-def 'style head-params))
76           (print-style  (lookup-def 'print-style head-params))
77           (canonical (lookup-def 'canonical head-params)))
78       (list (if style `(link (@ (rel "stylesheet") (type "text/css") (href ,style))) '())
79             (if print-style `(link (@ (rel "stylesheet") (type "text/css") 
80                                       (media "print")  (href ,print-style))) '())
81             (if canonical `(link (@ (rel "canonical") (href ,canonical))) '())))
82    ;; Remove already processed head parameters, inserting only unprocessed ones
83    ,@(remove (lambda (param)
84                (member (car param) '(title style print-style canonical
85                                            new-file existing-file
86                                            read-only read-write)))
87              head-params)))
88
89(define (internal-link r)
90  (pre-post-order* 
91   r
92   `((*default* . ,(lambda (tag . elems) elems))
93     (*text* . ,(lambda (trigger str) 
94                  (let ((str (string-downcase str)))
95                    (fold (lambda (regex/subst str)
96                            (irregex-replace/all (car regex/subst) str (cdr regex/subst)))
97                          str
98                          '(("^[^a-z]+" . "")
99                            ("[^a-z0-9_ \t-]" . "")
100                            ("[ \t]+" . "-")))))))))
101
102(define (qwiki-html-transformation-rules content)
103  `(((wiki-page 
104      *macro*
105      . ,(lambda (tag elems)
106           `(html:begin . ,elems)))
107
108     ;; Maybe this should be done in multiple steps to make it more "hookable"
109     (history
110      *macro* 
111      . ,(lambda (tag items)
112           `(table
113             (tr (th "revision")
114                 (th "author")
115                 (th "date")
116                 (th "description"))
117             ,@(map (lambda (item)
118                      ;; TODO: The nofollow should really apply to the
119                      ;; entire page instead of each individual link.
120                      `(tr (td (a (@ (rel "nofollow")
121                                     (href ,(string-append
122                                             "?action=show&rev="
123                                             (number->string (car item)))))
124                                  ,(car item)))
125                           (td ,(cadr item))
126                           (td ,(time->string (caddr item)))
127                           (td ,(cadddr item))))
128                    items))))
129
130     (wiki-content
131      *macro* .
132      ,(lambda (tag contents)
133         `(div (@ (id "content")) . ,contents)))
134
135     (tags
136      *preorder* .
137      ,(lambda (tag page-tags)
138         `(ul (@ (class "tags"))
139              . ,(map (lambda (tag) `(li ,tag))
140                      (string-split (car page-tags))))))
141
142     (highlight
143      *macro*
144      . ,(lambda (tag elems)
145           (let* ((lang (car elems))
146                  (classname (conc "highlight " lang "-language"))
147                  (code (handle-exceptions exn
148                            (cdr elems)
149                          (map (lambda (s)
150                                 (cdr (html->sxml (html-colorize lang s))))
151                               (cdr elems)))))
152             `(pre (@ (class ,classname)) . ,code))))
153
154     (examples
155      ((example
156        ((init
157          *macro*
158          . ,(lambda (tag elems)
159               `(div (@ (class "init")) (highlight scheme . ,elems))))
160         (expr
161          *macro*
162          . ,(lambda (tag elems)
163               `(div (@ (class "expression")) (highlight scheme . ,elems))))
164         (input
165          *macro*
166          . ,(lambda (tag elems)
167               `(div (@ (class "io input")) (em "input: ")
168                     (highlight scheme . ,elems))))
169         (output
170          *macro*
171          . ,(lambda (tag elems)
172               `(div (@ (class "io output")) (em "output: ")
173                     (highlight scheme . ,elems))))
174         (result
175          *macro*
176          . ,(lambda (tag elems)
177               `(div (@ (class "result"))
178                     (span (@ (class "result-symbol")) " => ")
179                     (highlight scheme . ,elems))))) ;; Or use "basic lisp" here?
180        . ,(lambda (tag elems)
181             `(div (@ (class "example")) . ,elems))))
182      . ,(lambda (tag elems)
183           `(div (@ (class "examples"))
184                 (span (@ (class "examples-heading")) "Examples:") . ,elems)))
185
186     (page-specific-links
187      *macro* 
188      . ,(lambda (tag elems)
189           `(ul (@ (id "page-specific-links"))
190                (li ,(if ((if-sxpath '(// new-file)) (cons tag elems))
191                         `(span (@ (class "disabled")
192                                   (title "This page doesn't exist yet"))
193                                "show")
194                         `(a (@ (href "?action=show")) "show")))
195                (li ,(if ((if-sxpath '(// read-only)) (cons tag elems))
196                         `(span (@ (class "disabled")
197                                   (title "This page has been frozen. "
198                                          "Only someone with direct access "
199                                          "to the repository can edit it."))
200                                "edit")
201                         `(a (@ (href "?action=edit") (rel "nofollow")) "edit")))
202                (li ,(if ((if-sxpath '(// new-file)) (cons tag elems))
203                         `(span (@ (class "disabled")
204                                   (title "This page doesn't exist yet"))
205                                "history")
206                         `(a (@ (href "?action=history")) "history"))))))
207
208     (@ *preorder* . ,(lambda (tag elements) (cons tag elements)))
209
210     (Header
211      *preorder*
212      . ,(lambda (tag headers)
213           (make-html-header headers)))
214
215     (toc ;; Re-scan the content for "section" tags and generate
216      *macro*
217      . ,(lambda (tag rest) ;; the table of contents
218           `(div (@ (id "toc"))
219                 ,rest
220                 (ol ,(let find-sections ((content content))
221                        (cond
222                         ((not (pair? content)) '())
223                         ((pair? (car content))
224                          (append (find-sections (car content))
225                                  (find-sections (cdr content))))
226                         ((eq? (car content) 'section)
227                          (let* ((level (cadr content))
228                                 (head-word (caddr content))
229                                 (href (list "#" (internal-link head-word)))
230                                 (subsections (find-sections (cdddr content))))
231                            (cond ((and (integer? level) head-word)
232                                   `((li (a (@ (href (,href))) ,head-word)
233                                         ,@(if (null? subsections)
234                                               '()
235                                               `((ol ,subsections))))))
236                                  (else
237                                   (error 'html-transformation-rules
238                                          "section elements must be of the form (section level head-word . contents)")))))
239                         (else (find-sections (cdr content)))))))))
240
241     (section
242      *macro*
243      . ,(lambda (tag elems)
244           (let ((level (car elems))
245                 (head-word (cadr elems))
246                 (contents (cddr elems)))
247             (cond ((and (integer? level) head-word)
248                    `((,(string->symbol (string-append "h" (number->string level)))
249                       (@ (id ,(internal-link head-word)))
250                       ,head-word ) . ,contents))
251                   (else
252                    (error 'html-transformation-rules
253                           (conc "section elements must be of the form (section level head-word . contents), got " elems)))))))
254
255     (section*
256      *macro*
257      . ,(lambda (tag elems)
258           (let ((level (car elems))
259                 (head-word (cadr elems))
260                 (contents (cddr elems)))
261             (cond ((and (integer? level) head-word)
262                    `((,(string->symbol (string-append "h" (number->string level)))
263                       ,head-word ) . ,contents))
264                   (else
265                    (error 'html-transformation-rules
266                           (conc "section elements must be of the form (section level head-word . contents), got " elems)))))))
267
268     (def
269      ((sig . ,(lambda (tag types)
270                 (map (lambda (spec)
271                        `(span (@ (class ,(conc "definition " (car spec))))
272                               (em "[" ,(symbol->string (car spec)) "]")
273                               " " (tt ,@(cdr spec)) (br)))
274                      types))))
275      . ,(lambda (tag elems) elems))
276
277     (pre
278      . ,(lambda (tag elems)
279           `(pre (tt . ,elems))))
280
281     (image-link
282      *macro*
283      . ,(lambda (tag elems)
284           `(img (@ (src ,(car elems)) . ,(if (null? (cdr elems))
285                                              '()
286                                              `((alt ,(cadr elems))
287                                                (title ,(cadr elems))))))))
288
289     (int-link
290      *macro*
291      . ,(lambda (tag elems)
292           ;; Normalize links so people can refer to sections by their proper name
293           (let* ((parts (string-split (car elems) "#" #t))
294                  (nparts (intersperse
295                           (cons (car parts) (internal-link (cdr parts)))
296                           "#")))
297             `(a (@ (href ,@nparts) (class "internal"))
298                 ,(if (null? (cdr elems)) (car elems) (cadr elems))))))
299
300     (link
301      *macro*
302      . ,(lambda (tag elems)
303           `(a (@ (href ,(car elems)) (class "external"))
304               ,(if (null? (cdr elems)) (car elems) (cadr elems)))))
305
306     ,@alist-conv-rules*)
307
308    ((html:begin
309      . ,(lambda (tag elems)
310           (list xhtml-1.0-strict
311                 "<html xmlns=\"http://www.w3.org/1999/xhtml\">"
312                 elems
313                 "</html>")))
314
315     (verbatim
316      *preorder*
317      . ,(lambda (tag elems)
318           elems))
319
320     ,@universal-conversion-rules*)))
321
322)
Note: See TracBrowser for help on using the repository browser.