Context Navigation

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

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats: