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

Last change on this file since 15101 was 15101, checked in by felix winkelmann, 10 years ago

merged trunk changes from 14491:15100 into prerelease branch

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