source: project/chicken/trunk/scripts/wiki2html.scm @ 13581

Last change on this file since 13581 was 13581, checked in by felix winkelmann, 11 years ago

miscellaneous trivialities

File size: 4.9 KB
Line 
1;;;; wiki2html.scm - quick-and-dirty svnwiki->HTML conversion
2;
3; usage: wiki2html <INPUTFILE >OUTPUTFILE
4
5
6(use regex srfi-1 extras utils)
7(use htmlprag matchable)
8
9
10;;; inline elements
11
12(define +code+ '(: #\{ #\{ (submatch (* (~ #\}))) #\} #\}))
13(define +bold+ '(: (= 3 #\') (submatch (* (~ #\'))) (= 3 #\')))
14(define +italic+ '(: (= 2 #\') (submatch (* (~ #\'))) (= 2 #\')))
15(define +html-tag+ '(: #\< (submatch (* (~ #\>))) #\>))
16
17(define +link+
18  '(: #\[ #\[ (? (: (* space) "image:" (* space)))
19      (submatch (* (~ #\] #\|))) (? #\| (submatch (* (~ #\])))) #\] #\]))
20
21(define +inline-element+
22  `(or ,+code+ ,+link+ ,+html-tag+ ,+bold+ ,+italic+))
23
24
25;;; Block elements
26
27(define +header+ '(: (submatch (>= 2 #\=)) (* space) (submatch (* any))))
28(define +pre+ '(: (>= 1 space) (submatch (* any))))
29(define +d-list+ '(: (* space) #\; (submatch (~ #\:)) #\: (submatch (* any))))
30(define +u-list+ '(: (* space) (submatch (>= 1 #\*)) (* space) (submatch (* any))))
31(define +o-list+ '(: (* space) (submatch (>= 1 #\*)) #\# (* space) (submatch (* any))))
32(define +hr+ '(: (* space) (submatch (>= 3 #\-)) (* space)))
33(define +emptyline+ '(: bos (* space) eos))
34
35(define +block-element+
36  `(or ,+pre+
37       ,+header+
38       ,+d-list+
39       ,+u-list+
40       ,+o-list+
41       ,+hr+))
42
43
44;;; Global state
45
46(define *toc* #f)
47(define *tags* '())
48(define *open* '())
49
50(define (push-tag tag out)
51  (unless (and (pair? *open*) (equal? tag (car *open*)))
52    (when (pair? *open*)
53      (pop-tag out))
54    (fprintf out "<~a>~%" (if (pair? tag) (car tag) tag))
55    (set! *open* (cons tag *open*))))
56
57(define (pop-tag out)
58  (let ((tag (car *open*)))
59    (fprintf out "</~a>~%" (if (pair? tag) (car tag) tag))
60    (set! *open* (cdr *open*))))
61
62(define (pop-all out)
63  (when (pair? *open*)
64    (pop-tag out)
65    (pop-all out)))
66
67
68;;; Helper syntax
69
70(define-syntax rx
71  (syntax-rules ()
72    ((_ rx) (force (delay (regexp rx))))))
73
74
75;;; Conversion entry point
76
77(define (wiki->html #!optional (in (current-input-port)) (out (current-output-port)))
78  (call/cc
79   (lambda (return)
80     (let loop ()
81       (let ((ln (read-line in)))
82         (cond ((eof-object? ln) (return #f))
83               ((string-match (rx +emptyline+) ln)
84                (fprintf out "~%"))
85               ((not (string-match (rx +block-element+) ln)) 
86                (pop-all out)
87                (fprintf out "~a~%" (inline ln)))
88               ((string-match (rx +header+) ln) =>
89                (lambda (m)
90                  (pop-all out)
91                  (let ((n (sub1 (string-length (second m)))))
92                    (fprintf out "<h~a>~a</h~a>~%" n (third m) n))))
93               ((string-match (rx +pre+) ln) =>
94                (lambda (m)
95                  (push-tag 'pre out)))
96               ((string-match (rx +hr+) ln) =>
97                (lambda (m)
98                  (fprintf out "<hr />~%")))
99               ((string-match (rx +d-list+) ln) =>
100                (lambda (m)
101                  (push-tag 'dl out)
102                  (fprintf out "<dt>~a</dt><dd>~a</dd>~%" 
103                           (inline (second m)) (inline (third m)))))
104               ((string-match (rx +u-list+) ln) =>
105                (lambda (m)
106                  (push-tag `(ul . ,(string-length (second m))) out)
107                  (fprintf out "<li>~a~%" (inline (third m)))))
108               ((string-match (rx +o-list+) ln) =>
109                (lambda (m)
110                  (push-tag `(ol . ,(string-length (second m))) out)
111                  (fprintf out "<li>~a~%" (inline (third m)))))
112               (else (error "unknown block match" m))Ž)
113         (loop))))))
114
115
116;;; Substitute inline elements
117
118(define (inline str)
119  (or (and-let* ((m (string-search-positions (rx +inline-element+) str)))
120        (string-append
121         (clean (substring str 0 (caar m)))
122         (let ((rest (substring str (caar m))))
123           (define (continue m)
124             (inline (substring rest (string-length (first m)))))
125           (cond ((string-search (rx `(: bos ,+code+)) rest) =>
126                  (lambda (m)
127                    (string-append
128                     "<tt>" (clean (second m)) "</tt>"
129                     (continue m))))
130                 ((string-search (rx `(: bos ,+html-tag+)) rest) =>
131                  (lambda (m)
132                    (string-append
133                     (first m)
134                     (continue m))))
135                 ((string-search(rx `(: bos ,+link+)) rest) =>
136                  (lambda (m)
137                    (string-append
138                     "<a href='" (clean (second m)) "'>"
139                     (clean (or (third m) (second m)))
140                     "</a>"
141                     (continue m)))) 
142                 ((string-search (rx `(: bos ,+bold+)) rest) =>
143                  (lambda (m)
144                    (string-append
145                     "<b>" (inline (second m)) "</b>"
146                     (continue m)))) 
147                 ((search (rx `(: bos ,+italic+)) rest) =>
148                  (lambda (m)
149                    (string-append
150                     "<i>" (inline (second m)) "</i>"
151                     (continue m)))) 
152                 (else (error "unknown inline match" m rest))))))
153      str))
154
155
156;;; Normalize text
157
158(define (clean str)
159  (string-translate* str '(("<" . "&lt;") ("&" . "&amp;") ("'" . "&quot;"))))
160
161
162;;; run it
163
164(let ((sxml (html->sxml (open-input-string (with-output-to-string wiki->html)))))
165  (define (walk n)
166    (match n
167      (('*PI* . _) n)
168      (('enscript strs ...)
169       `(pre ,@strs))
170      (((? symbol? tag) . body)
171       `(,tag ,@(map walk body)))
172      (_ n)))
173  (sxml->html (walk sxml)))
Note: See TracBrowser for help on using the repository browser.