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

Last change on this file since 13669 was 13669, checked in by felix winkelmann, 12 years ago

manual fixes

File size: 6.4 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 srfi-13 posix)
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
34(define +block-element+
35  `(or ,+pre+
36       ,+header+
37       ,+d-list+
38       ,+u-list+
39       ,+o-list+
40       ,+hr+))
41
42
43;;; Global state
44
45(define *tags* '())
46(define *open* '())
47(define *manual-pages* '())
48
49(define (push-tag tag out)
50  (unless (and (pair? *open*) (equal? tag (car *open*)))
51    (when (pair? *open*)
52      (pop-tag out))
53    (fprintf out "<~a>~%" (if (pair? tag) (car tag) tag))
54    (set! *open* (cons tag *open*))))
55
56(define (pop-tag out)
57  (let ((tag (car *open*)))
58    (fprintf out "</~a>~%" (if (pair? tag) (car tag) tag))
59    (set! *open* (cdr *open*))))
60
61(define (pop-all out)
62  (when (pair? *open*)
63    (pop-tag out)
64    (pop-all out)))
65
66
67;;; Helper syntax
68
69(define-syntax rx
70  (syntax-rules ()
71    ((_ rx) (force (delay (regexp rx))))))
72
73
74;;; Conversion entry point
75
76(define (wiki->html #!optional (in (current-input-port)) (out (current-output-port)))
77  (call/cc
78   (lambda (return)
79     (let loop ()
80       (let ((ln (read-line in)))
81         (cond ((eof-object? ln) (return #f))
82               ((not (string-match (rx +block-element+) ln)) 
83                (cond ((string-null? ln) (display "<br />\n" out))
84                      (else
85                       (pop-all out)
86                       (fprintf out "~a~%" (inline ln)))))
87               ((string-match (rx +header+) ln) =>
88                (lambda (m)
89                  (pop-all out)
90                  (let ((n (sub1 (string-length (second m))))
91                        (name (clean (third m))))
92                    (fprintf out "<a name='~a' /><h~a>~a</h~a>~%" 
93                             name n name n))))
94               ((string-match (rx +pre+) ln) =>
95                (lambda (m)
96                  (push-tag 'pre out)
97                  (fprintf out "~a~%" (clean (car m)))))
98               ((string-match (rx +hr+) ln) =>
99                (lambda (m)
100                  (fprintf out "<hr />~%")))
101               ((string-match (rx +d-list+) ln) =>
102                (lambda (m)
103                  (push-tag 'dl out)
104                  (fprintf out "<dt>~a</dt><dd>~a</dd>~%" 
105                           (inline (second m)) (inline (third m)))))
106               ((string-match (rx +u-list+) ln) =>
107                (lambda (m)
108                  (push-tag `(ul . ,(string-length (second m))) out)
109                  (fprintf out "<li>~a~%" (inline (third m)))))
110               ((string-match (rx +o-list+) ln) =>
111                (lambda (m)
112                  (push-tag `(ol . ,(string-length (second m))) out)
113                  (fprintf out "<li>~a~%" (inline (third m)))))
114               (else (error "unknown block match" m))Ž)
115         (loop))))))
116
117
118;;; Substitute inline elements
119
120(define (inline str)
121  (or (and-let* ((m (string-search-positions (rx +inline-element+) str)))
122        (string-append
123         (clean (substring str 0 (caar m)))
124         (let ((rest (substring str (caar m))))
125           (define (continue m)
126             (inline (substring rest (string-length (first m)))))
127           (cond ((string-search (rx `(: bos ,+code+)) rest) =>
128                  (lambda (m)
129                    (string-append
130                     "<tt>" (clean (second m)) "</tt>"
131                     (continue m))))
132                 ((string-search (rx `(: bos ,+html-tag+)) rest) =>
133                  (lambda (m)
134                    (string-append
135                     (first m)
136                     (continue m))))
137                 ((string-search (rx `(: bos ,+link+)) rest) =>
138                  (lambda (m)
139                    (let ((m1 (string-trim-both (second m))))
140                      (string-append
141                       (cond ((or (string=? "toc:" m1)
142                                  (string-search (rx '(: bos (* space) "tags:")) m1) )
143                              "")
144                             ((member m1 *manual-pages*)
145                              (string-append
146                               "<a href='" (clean m1) ".html'>" (clean m1) "</a>"))
147                             (else
148                              (string-append
149                               "<a href='" (clean (second m)) "'>"
150                               (clean (or (third m) (second m)))
151                               "</a>")))
152                       (continue m)))))
153                 ((string-search (rx `(: bos ,+bold+)) rest) =>
154                  (lambda (m)
155                    (string-append
156                     "<b>" (inline (second m)) "</b>"
157                     (continue m)))) 
158                 ((string-search (rx `(: bos ,+italic+)) rest) =>
159                  (lambda (m)
160                    (string-append
161                     "<i>" (inline (second m)) "</i>"
162                     (continue m)))) 
163                 (else (error "unknown inline match" m rest))))))
164      str))
165
166(define (convert name)
167  (let ((sxml (html->sxml (open-input-string (with-output-to-string wiki->html)))))
168    (define (walk n)
169      (match n
170        (('*PI* . _) "")
171        (('enscript strs ...)
172         `(pre ,@(match strs
173                   ((('@ . _) . strs) strs)
174                   (_ strs))))
175        (('procedure strs ...)
176         `(pre "\n [procedure] " ,@strs))
177        (((? symbol? tag) ('@ attr ...) . body)
178         `(,tag (@ ,@attr) ,@(map walk body)))
179        (((? symbol? tag) . body)
180         `(,tag ,@(map walk body)))
181        (_ n)))
182    (display
183     (shtml->html
184      (wrap name (walk `(body ,@(cdr sxml))))))))
185
186(define (wrap name body)
187  `(html (head (title ,(string-append "The CHICKEN User's Manual - " name)))
188         ,body))
189
190
191;;; Normalize text
192
193(define (clean str)
194  (string-translate* str '(("<" . "&lt;") ("&" . "&amp;") ("'" . "&apos;") ("\"" . "&quot;"))))
195
196
197;;; Run it
198
199(define (main args)
200  (let ((outdir "."))
201    (let loop ((args args))
202      (match args
203        (()
204         (print "usage: wiki2html [-o DIRECTORY] PAGEFILE ...")
205         (exit 1))
206        (("-o" dir . more)
207         (set! outdir dir)
208         (loop more))
209        ((files ...)
210         (let ((dirs (delete-duplicates (map pathname-directory files) string=?)))
211           (set! *manual-pages* (map pathname-strip-directory (append-map directory dirs)))
212           (for-each
213            (lambda (file)
214              (print file)
215              (with-input-from-file file 
216                (lambda ()
217                  (with-output-to-file (pathname-replace-directory (string-append file ".html") outdir) 
218                    (cut convert (pathname-file file))))))
219            files)))))))
220
221
222(main (command-line-arguments))
Note: See TracBrowser for help on using the repository browser.