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

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

wiki2html work; fixed table in manual

File size: 6.3 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(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 *tags* '())
47(define *open* '())
48(define *manual-pages* '())
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                        (name (clean (third m))))
93                    (fprintf out "<a name='~a' /><h~a>~a</h~a>~%" 
94                             name n name n))))
95               ((string-match (rx +pre+) ln) =>
96                (lambda (m)
97                  (push-tag 'pre out)
98                  (display (clean (car m)))))
99               ((string-match (rx +hr+) ln) =>
100                (lambda (m)
101                  (fprintf out "<hr />~%")))
102               ((string-match (rx +d-list+) ln) =>
103                (lambda (m)
104                  (push-tag 'dl out)
105                  (fprintf out "<dt>~a</dt><dd>~a</dd>~%" 
106                           (inline (second m)) (inline (third m)))))
107               ((string-match (rx +u-list+) ln) =>
108                (lambda (m)
109                  (push-tag `(ul . ,(string-length (second m))) out)
110                  (fprintf out "<li>~a~%" (inline (third m)))))
111               ((string-match (rx +o-list+) ln) =>
112                (lambda (m)
113                  (push-tag `(ol . ,(string-length (second m))) out)
114                  (fprintf out "<li>~a~%" (inline (third m)))))
115               (else (error "unknown block match" m))Ž)
116         (loop))))))
117
118
119;;; Substitute inline elements
120
121(define (inline str)
122  (or (and-let* ((m (string-search-positions (rx +inline-element+) str)))
123        (string-append
124         (clean (substring str 0 (caar m)))
125         (let ((rest (substring str (caar m))))
126           (define (continue m)
127             (inline (substring rest (string-length (first m)))))
128           (cond ((string-search (rx `(: bos ,+code+)) rest) =>
129                  (lambda (m)
130                    (string-append
131                     "<tt>" (clean (second m)) "</tt>"
132                     (continue m))))
133                 ((string-search (rx `(: bos ,+html-tag+)) rest) =>
134                  (lambda (m)
135                    (string-append
136                     (first m)
137                     (continue m))))
138                 ((string-search (rx `(: bos ,+link+)) rest) =>
139                  (lambda (m)
140                    (let ((m1 (string-trim-both (second m))))
141                      (string-append
142                       (cond ((or (string=? "toc:" m1)
143                                  (string-search (rx '(: bos (* space) "tags:")) m1) )
144                              "")
145                             ((member m1 *manual-pages*)
146                              (string-append
147                               "<a href='" m1 ".html'>" m1 "</a>"))
148                             (else
149                              (string-append
150                               "<a href='" (clean (second m)) "'>"
151                               (clean (or (third m) (second m)))
152                               "</a>")))
153                       (continue m)))))
154                 ((string-search (rx `(: bos ,+bold+)) rest) =>
155                  (lambda (m)
156                    (string-append
157                     "<b>" (inline (second m)) "</b>"
158                     (continue m)))) 
159                 ((string-search (rx `(: bos ,+italic+)) rest) =>
160                  (lambda (m)
161                    (string-append
162                     "<i>" (inline (second m)) "</i>"
163                     (continue m)))) 
164                 (else (error "unknown inline match" m rest))))))
165      str))
166
167(define (convert name)
168  (let ((sxml (html->sxml (open-input-string (with-output-to-string wiki->html)))))
169    (define (walk n)
170      (match n
171        (('*PI* . _) "")
172        (('*TOP* . n) n)
173        (('enscript strs ...)
174         `(pre ,@strs))
175        (('procedure strs ...)
176         `(pre "\n [procedure] " ,@strs))
177        (((? symbol? tag) . body)
178         `(,tag ,@(map walk body)))
179        (_ n)))
180    (display
181     (shtml->html
182      (wrap name (walk sxml))))))
183
184(define (wrap name body)
185  `(html (head (title ,(string-append "The CHICKEN User's Manual - " name)))
186         (body ,@body)))
187
188
189;;; Normalize text
190
191(define (clean str)
192  (string-translate* str '(("<" . "&lt;") ("&" . "&amp;") ("'" . "&rsquo;"))))
193
194
195;;; Run it
196
197(define (main args)
198  (let ((outdir "."))
199    (let loop ((args args))
200      (match args
201        (()
202         (print "usage: wiki2html [-o DIRECTORY] PAGEFILE ...")
203         (exit 1))
204        (("-o" dir . more)
205         (set! outdir dir)
206         (loop more))
207        ((files ...)
208         (let ((dirs (delete-duplicates (map pathname-directory files) string=?)))
209           (set! *manual-pages* (map pathname-strip-directory (append-map directory dirs)))
210           (for-each
211            (lambda (file)
212              (print file)
213              (with-input-from-file file 
214                (lambda ()
215                  (with-output-to-file (pathname-replace-directory (string-append file ".html") outdir) 
216                    (cut convert (pathname-file file))))))
217            files)))))))
218
219
220(main (command-line-arguments))
Note: See TracBrowser for help on using the repository browser.