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 '(("<" . "&lt;") ("&" . "&amp;") ("'" . "&apos;") ("\"" . "&quot;"))))
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.