source: project/chicken/branches/prerelease/scripts/wiki2html.scm @ 13859

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

merged trunk rev. 13858 (not including srandom change)

File size: 8.1 KB
Line 
1;;;; wiki2html.scm - quick-and-dirty svnwiki->HTML conversion
2;
3; usage: wiki2html <INPUTFILE >OUTPUTFILE
4
5
6(load-relative "tools.scm")
7
8(use regex srfi-1 extras utils srfi-13 posix)
9(use htmlprag matchable)
10
11
12;;; inline elements
13
14(define +code+ '(: #\{ #\{ (submatch (*? any)) #\} #\}))
15(define +bold+ '(: (= 3 #\') (submatch (* (~ #\'))) (= 3 #\')))
16(define +italic+ '(: (= 2 #\') (submatch (* (~ #\'))) (= 2 #\')))
17(define +html-tag+ '(: #\< (submatch (* (~ #\>))) #\>))
18
19(define +link+
20  '(: #\[ #\[ (submatch (* (~ #\] #\|))) (? #\| (submatch (* (~ #\])))) #\] #\]))
21
22(define +image-link+
23  '(: #\[ #\[ (* space) "image:" (* space)
24      (submatch (* (~ #\] #\|))) (? #\| (submatch (* (~ #\])))) #\] #\]))
25
26(define +inline-element+
27  `(or ,+code+ ,+image-link+ ,+link+ ,+html-tag+ ,+bold+ ,+italic+))
28
29(define +http-url+ '(: (* space) "http://" (* any)))
30
31
32;;; Block elements
33
34(define +header+ '(: (submatch (>= 2 #\=)) (* space) (submatch (* any))))
35(define +pre+ '(: (>= 1 space) (submatch (* any))))
36
37(define +d-list+
38  '(: (* space) #\; (submatch (*? any)) #\space #\: #\space (submatch (* any))))
39
40(define +d-head+ '(: (* space) #\; (submatch (* any))))
41(define +u-list+ '(: (* space) (submatch (>= 1 #\*)) (* space) (submatch (* any))))
42(define +o-list+ '(: (* space) (submatch (>= 1 #\*)) #\# (* space) (submatch (* any))))
43(define +hr+ '(: (* space) (submatch (>= 3 #\-)) (* space)))
44
45(define +block-element+
46  `(or ,+pre+
47       ,+header+
48       ,+d-list+
49       ,+d-head+
50       ,+u-list+
51       ,+o-list+
52       ,+hr+))
53
54
55;;; Global state
56
57(define *tags* '())
58(define *open* '())
59(define *manual-pages* '())
60(define *list-continuation* #f)
61
62(define (push-tag tag out)
63  ;(fprintf (current-error-port) "start: tag: ~a, open: ~a~%" tag *open*)
64  (unless (and (pair? *open*) (equal? tag (car *open*)))
65    (when (pair? *open*)
66      (cond ((not (pair? tag)) (pop-tag out))
67            ((pair? (car *open*))
68             ;(fprintf (current-error-port) "tag: ~a, open: ~a~%" tag *open*)
69             (when (< (cdr tag) (cdar *open*))
70               (do ((n (cdar *open*) (sub1 n)))
71                   ((= (cdr tag) n))
72                 (pop-tag out))))))
73    (unless (and (pair? *open*) (equal? tag (car *open*)))
74      (fprintf out "<~a>~%" (if (pair? tag) (car tag) tag))
75      (set! *list-continuation* #f)
76      ;(fprintf (current-error-port) "PUSH: ~a~%" tag)
77      (set! *open* (cons tag *open*)))))
78
79(define (pop-tag out)
80  (let ((tag (car *open*)))
81    ;(fprintf (current-error-port) "POP: ~a~%" *open*)
82    (fprintf out "</~a>~%" (if (pair? tag) (car tag) tag))
83    (set! *open* (cdr *open*))))
84
85(define (pop-all out)
86  (when (pair? *open*)
87    (pop-tag out)
88    (pop-all out)))
89
90
91;;; Helper syntax
92
93(define-syntax rx
94  (syntax-rules ()
95    ((_ rx) (force (delay (regexp rx))))))
96
97
98;;; Conversion entry point
99
100(define (wiki->html #!optional (in (current-input-port)) (out (current-output-port)))
101  (call/cc
102   (lambda (return)
103     (let loop ()
104       (let ((ln (read-line in)))
105         (cond ((eof-object? ln) (return #f))
106               ((not (string-match (rx +block-element+) ln)) 
107                (cond ((string-null? ln)
108                       (display "<br />\n" out)
109                       (set! *list-continuation* #f))
110                      (else
111                       (pop-all out)
112                       (fprintf out "~a~%" (inline ln)))))
113               ((string-match (rx +header+) ln) =>
114                (lambda (m)
115                  (pop-all out)
116                  (let ((n (sub1 (string-length (second m))))
117                        (name (clean (third m))))
118                    (fprintf out "<a name='~a' /><h~a>~a</h~a>~%" 
119                             name n name n))))
120               ((string-match (rx +pre+) ln) =>
121                (lambda (m)
122                  (cond (*list-continuation* 
123                         (fprintf out "~a~%" (inline (second m))))
124                        (else
125                         (push-tag 'pre out)
126                         (fprintf out "~a~%" (clean (car m)))))))
127               ((string-match (rx +hr+) ln) =>
128                (lambda (m)
129                  (fprintf out "<hr />~%")))
130               ((string-match (rx +d-list+) ln) =>
131                (lambda (m)
132                  (push-tag 'dl out)
133                  (set! *list-continuation* #t)
134                  (fprintf out "<dt>~a</dt><dd>~a</dd>~%" 
135                           (inline (second m)) (inline (or (third m) "")))))
136               ((string-match (rx +d-head+) ln) =>
137                (lambda (m)
138                  (push-tag 'dl out)
139                  (set! *list-continuation* #t)
140                  (fprintf out "<dt>~a</dt>~%" (inline (second m)))))
141               ((string-match (rx +u-list+) ln) =>
142                (lambda (m)
143                  (push-tag `(ul . ,(string-length (second m))) out)
144                  (set! *list-continuation* #t)
145                  (fprintf out "<li>~a~%" (inline (third m)))))
146               ((string-match (rx +o-list+) ln) =>
147                (lambda (m)
148                  (push-tag `(ol . ,(string-length (second m))) out)
149                  (set! *list-continuation* #t)
150                  (fprintf out "<li>~a~%" (inline (third m)))))
151               (else (error "unknown block match" m))Ž)
152         (loop))))))
153
154
155;;; Substitute inline elements
156
157(define (inline str)
158  (or (and-let* ((m (string-search-positions (rx +inline-element+) str)))
159        (string-append
160         (clean (substring str 0 (caar m)))
161         (let ((rest (substring str (caar m))))
162           (define (continue m)
163             (inline (substring rest (string-length (first m)))))
164           (cond ((string-search (rx `(: bos ,+code+)) rest) =>
165                  (lambda (m)
166                    (string-append
167                     "<tt>" (clean (second m)) "</tt>"
168                     (continue m))))
169                 ((string-search (rx `(: bos ,+html-tag+)) rest) =>
170                  (lambda (m)
171                    (string-append
172                     (first m)
173                     (continue m))))
174                 ((string-search (rx `(: bos ,+image-link+)) rest) =>
175                  (lambda (m)
176                    (string-append
177                     "<img src='" (clean (second m)) "' />"
178                     (continue m))))
179                 ((string-search (rx `(: bos ,+link+)) rest) =>
180                  (lambda (m)
181                    (let ((m1 (string-trim-both (second m))))
182                      (string-append
183                       (cond ((or (string=? "toc:" m1)
184                                  (string-search (rx '(: bos (* space) "tags:")) m1) )
185                              "")
186                             ((find (cut string-ci=? <> m1) *manual-pages*)
187                              (string-append
188                               "<a href='" (clean m1) ".html'>" (inline m1) "</a>"))
189                             (else
190                              (string-append
191                               "<a href='" 
192                               (clean
193                                (let ((href (second m)))
194                                  (if (string-match (rx +http-url+) href)
195                                      href
196                                      (string-append "http://chicken.wiki.br/" href))))
197                               "'>"
198                               (clean (or (third m) (second m)))
199                               "</a>")))
200                       (continue m)))))
201                 ((string-search (rx `(: bos ,+bold+)) rest) =>
202                  (lambda (m)
203                    (string-append
204                     "<b>" (inline (second m)) "</b>"
205                     (continue m)))) 
206                 ((string-search (rx `(: bos ,+italic+)) rest) =>
207                  (lambda (m)
208                    (string-append
209                     "<i>" (inline (second m)) "</i>"
210                     (continue m)))) 
211                 (else (error "unknown inline match" m rest))))))
212      str))
213
214(define (convert name)
215  (let ((sxml (html->sxml (open-input-string (with-output-to-string wiki->html)))))
216    (define (walk n)
217      (match n
218        (('*PI* . _) "")
219        (('enscript strs ...)
220         `(pre ,@(match strs
221                   ((('@ . _) . strs) strs)
222                   (_ strs))))
223        (('procedure strs ...)
224         `(pre "\n [procedure] " ,@strs))
225        (((? symbol? tag) ('@ attr ...) . body)
226         `(,tag (@ ,@attr) ,@(map walk body)))
227        (((? symbol? tag) . body)
228         `(,tag ,@(map walk body)))
229        (_ n)))
230    (display
231     (shtml->html
232      (let ((sxml (wrap name (walk `(body ,@(cdr sxml))))))
233        ;(pp sxml (current-error-port))
234        sxml)))))
235
236(define (wrap name body)
237  `(html (head (title ,(string-append "The CHICKEN User's Manual - " name))
238               (style (@ (type "text/css"))
239                 "@import url('manual.css');\n"))
240         ,body))
241
242
243;;; Normalize text
244
245(define (clean str)
246  (string-translate* str '(("<" . "&lt;") ("&" . "&amp;") ("'" . "&apos;") ("\"" . "&quot;"))))
247
248
249;;; Run it
250
251(define *outdir* ".")
252
253(define (main args)
254  (let loop ((args args))
255    (match args
256      (()
257       (print "usage: wiki2html [--outdir=DIRECTORY] PAGEFILE ...")
258       (exit 1))
259      ((files ...)
260       (let ((dirs (delete-duplicates (map pathname-directory files) string=?)))
261         (set! *manual-pages* (map pathname-strip-directory (append-map directory dirs)))
262         (for-each
263          (lambda (file)
264            (print file)
265            (with-input-from-file file 
266              (lambda ()
267                (with-output-to-file (pathname-replace-directory (string-append file ".html") *outdir*) 
268                  (cut convert (pathname-file file))))))
269          files))))))
270
271(main (simple-args))
Note: See TracBrowser for help on using the repository browser.