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

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

small manual fixes; merged wiki changes (rev. 13647) into manual

File size: 5.5 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                    (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                    (let ((m1 (string-trim-both (second m))))
138                      (string-append
139                       (cond ((or (string=? "toc:" m1)
140                                  (string-search (rx '(: bos (* space) "tags:")) m1) )
141                              "")
142                             ((member m1 *manual-pages*)
143                              (string-append
144                               "<a href='" m1 ".html'>" m1 "</a>"))
145                             (else
146                              (string-append
147                               "<a href='" (clean (second m)) "'>"
148                               (clean (or (third m) (second m)))
149                               "</a>")))
150                       (continue m)))))
151                 ((string-search (rx `(: bos ,+bold+)) rest) =>
152                  (lambda (m)
153                    (string-append
154                     "<b>" (inline (second m)) "</b>"
155                     (continue m)))) 
156                 ((search (rx `(: bos ,+italic+)) rest) =>
157                  (lambda (m)
158                    (string-append
159                     "<i>" (inline (second m)) "</i>"
160                     (continue m)))) 
161                 (else (error "unknown inline match" m rest))))))
162      str))
163
164(define (convert)
165  (let ((sxml (html->sxml (open-input-string (with-output-to-string wiki->html)))))
166    (define (walk n)
167      (match n
168        (('*PI* . _) n)
169        (('enscript strs ...)
170         `(pre ,@strs))
171        (('procedure strs ...)
172         `(pre "\n [procedure] " (tt ,@strs)))
173        (((? symbol? tag) . body)
174         `(,tag ,@(map walk body)))
175        (_ n)))
176    (display (shtml->html (walk sxml)))))
177
178
179;;; Normalize text
180
181(define (clean str)
182  (string-translate* str '(("<" . "&lt;") ("&" . "&amp;") ("'" . "&quot;"))))
183
184
185;;; Run it
186
187(define (main args)
188  (match args
189    ((dir)
190     (set! *manual-pages* (map pathname-strip-directory (directory dir)))
191     (convert))
192    (_ (print "usage: wiki2html MANUALDIRECTORY")
193       (exit 1))))
194
195(main (command-line-arguments))
Note: See TracBrowser for help on using the repository browser.