source: project/release/4/wiki-parse/wiki-parse.scm @ 15361

Last change on this file since 15361 was 15361, checked in by sjamaan, 11 years ago

Fix (named) URL parsing and add it to the tests

File size: 11.4 KB
Line 
1;;
2;; Wiki content parser.
3;;
4;; Based on wiki-parse.scm by Alex Shinn. Modified for svnwiki syntax
5;; by Ivan Raikov.
6;;
7;; Copyright 2009 Alex Shinn, Ivan Raikov.
8;;
9;;
10;;  Redistribution and use in source and binary forms, with or without
11;;  modification, are permitted provided that the following conditions
12;;  are met:
13;;
14;;  - Redistributions of source code must retain the above copyright
15;;  notice, this list of conditions and the following disclaimer.
16;;
17;;  - Redistributions in binary form must reproduce the above
18;;  copyright notice, this list of conditions and the following
19;;  disclaimer in the documentation and/or other materials provided
20;;  with the distribution.
21;;
22;;  - Neither name of the copyright holders nor the names of its
23;;  contributors may be used to endorse or promote products derived
24;;  from this software without specific prior written permission.
25;;
26;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE
27;;  CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
28;;  INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
29;;  MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
30;;  DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR THE
31;;  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
32;;  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
33;;  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
34;;  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
35;;  AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
36;;  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
37;;  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
38;;  POSSIBILITY OF SUCH DAMAGE.
39;;
40
41
42(module wiki-parse
43
44        (wiki-parse wiki-word-encode wiki-word-decode)
45
46        (import scheme chicken irregex)
47
48        (require-extension extras regex data-structures srfi-1 srfi-13 html-parser)
49
50(define (safe-assoc k lst)
51  (and (pair? lst) (or (and (pair? (car lst)) (eq? k (caar lst)) (caar lst)) 
52                       (safe-assoc k (cdr lst)))))
53 
54
55;; translate a wiki word to a safe pathname (after escaping, colons
56;; ':' are translated to slashes '/' to create a diretory hierarchy of
57;; wiki words)
58(define wiki-word-encode
59  (let ((wiki-unsafe-rx (irregex "[^!--0-Z^-~]")))
60    (lambda (str)
61      (string-translate
62       (irregex-replace/all
63        wiki-unsafe-rx
64        str
65        (lambda (m)
66          (let ((n (char->integer (string-ref (irregex-match-substring m) 0))))
67            (string-append "_" (if (< n 16) "0" "")
68                           (string-upcase (number->string n 16))))))
69       ":"
70       "/"))))
71
72;; reverse the above
73(define wiki-word-decode
74  (let ((wiki-escaped-rx (irregex "_([0-9a-fA-F][0-9a-fA-F])")))
75    (lambda (str)
76      (irregex-replace/all
77       wiki-escaped-rx
78       (string-translate str "/" ":")
79       (lambda (m)
80         (string
81          (integer->char
82           (string->number (irregex-match-substring m 1) 16))))))))
83
84(define (%irregex-multi-fold ls str start end)
85  (cond
86   ((null? ls)
87    (if (>= start end) '() (list (substring str start end))))
88   (else
89    (irregex-fold
90     (caar ls)
91     (lambda (i m x)
92       (let ((left (%irregex-multi-fold (cdr ls) str i (irregex-match-start m)))
93             (right (reverse (irregex-apply-match m (cdar ls)))))
94         (append x left right)))
95     '()
96     str
97     (lambda (i x)
98       (append x (%irregex-multi-fold (cdr ls) str i end)))
99     start
100     end))))
101
102(define (irregex-multi-fold ls str . o)
103  (let ((start (if (pair? o) (car o) 0))
104        (end (if (and (pair? o) (pair? (cdr o)))
105                 (cadr o)
106                 (string-length str))))
107    (%irregex-multi-fold ls str start end)))
108
109(define (irregex-split irx str)
110  (reverse
111   (irregex-fold
112    irx
113    (lambda (i m x)
114      (let ((j (irregex-match-start m)))
115        (if (> j i) (cons (substring str i j) x) x)))
116    '()
117    str
118    (lambda (i x)
119      (if (< i (- (string-length str) 1))
120          (cons (substring str i) x)
121          x)))))
122
123(define wiki-parse-inline
124  (let ((wiki-bold-rx
125         (irregex "'''([^']+)'''")) 
126        (wiki-italic-rx
127         (irregex "''([^']+)''")) 
128        (wiki-big-rx
129         (irregex "<big>([^<]+)</big>"))
130        (wiki-small-rx
131         (irregex "<small>([^<]+)</small>"))
132        (wiki-type-rx
133         (irregex "\\{\\{([^\\}]+)\\}\\}")) 
134        (wiki-center-rx
135         (irregex "<center>([^<]+)</center>"))
136        (wiki-blockquote-rx
137         (irregex "<blockquote>([^<]+)</blockquote>"))
138        (wiki-uline-rx
139         (irregex "<u>([^<]+)</u>"))
140        (wiki-strike-out-rx
141         (irregex "<s>([^<]+)</s>"))
142        (wiki-table-rx
143         (irregex "\\{\\|(.*)\n((?:\\|[^}]|[^|])*)\\|\\}"))
144        (wiki-row-rx
145         (irregex "\n\\|- *"))
146        (wiki-col-rx
147         (irregex "\\|\\|"))
148        (wiki-named-url-rx
149         (irregex "\\[\\[((?:https?|ftp):/+[\\-+.,_/%?&~=:\\w]+[\\-+_/%?&~=:\\w])\\|[ \t\n]*([^\\]]*)\\]\\]"))
150        (wiki-url-rx
151         (irregex "((?:https?|ftp):/+[\\-+.,_/%?&~=:\\w]+[\\-+_/%?&~=:\\w])"))
152        (wiki-word-rx
153         (irregex "\\[\\[([^\\]|]+)(?:\\| *([^\\]|]+))?\\]\\]"))
154        (wiki-special-rx
155         (irregex "\\[\\[([a-z]+):([^\\]]*)\\]\\]")))
156    (lambda (str)
157      (irregex-multi-fold
158       `((,wiki-table-rx
159          ,(lambda (m)
160             (append
161              (car
162               (html->sxml
163                (string-append
164                 "<table "
165                 (or (irregex-match-substring m 1) "")
166                 ">")))
167              (map (lambda (row)
168                     (cons 'tr
169                           (map (lambda (col)
170                                  (cons 'td
171                                        (wiki-parse-inline
172                                         (string-trim-both col))))
173                                (irregex-split
174                                 wiki-col-rx
175                                 (string-trim
176                                  row
177                                  (lambda (c)
178                                    (or (char-whitespace? c) (eqv? c #\|))))))))
179                   (irregex-split
180                    wiki-row-rx
181                    (string-append "\n" (irregex-match-substring m 2)))))))
182         (,wiki-type-rx
183          ,(lambda (m)
184             (list 'type
185                   (wiki-parse-inline (irregex-match-substring m 1))
186                   #f)))
187         (,wiki-named-url-rx
188          ,(lambda (m)
189             (list 'url
190                   (irregex-match-substring m 1)
191                   (irregex-match-substring m 2))))
192         (,wiki-url-rx
193          ,(lambda (m)
194             (list 'url
195                   (irregex-match-substring m 1)
196                   (irregex-match-substring m 1))))
197         (,wiki-word-rx
198          ,(lambda (m)
199             (list 'wiki
200                   (irregex-match-substring m 1)
201                   (irregex-match-substring m 2))))
202         (,wiki-special-rx
203          ,(lambda (m) (list 'special (string->symbol (irregex-match-substring m 1))
204                             (string-trim-both (irregex-match-substring m 2)))))
205         (,wiki-blockquote-rx
206          ,(lambda (m) (list 'blockquote (irregex-match-substring m 1))))
207         (,wiki-small-rx
208          ,(lambda (m) (list 'small (irregex-match-substring m 1))))
209         (,wiki-big-rx
210          ,(lambda (m) (list 'big (irregex-match-substring m 1))))
211         (,wiki-center-rx
212          ,(lambda (m) (list 'center (irregex-match-substring m 1))))
213         (,wiki-bold-rx
214          ,(lambda (m) (list 'b (irregex-match-substring m 1))))
215         (,wiki-italic-rx
216          ,(lambda (m) (list 'i (irregex-match-substring m 1))))
217         (,wiki-uline-rx
218          ,(lambda (m) (list 'u (irregex-match-substring m 1))))
219         (,wiki-strike-out-rx
220          ,(lambda (m) (list 's (irregex-match-substring m 1))))
221         )
222       str))))
223
224(define wiki-parse
225  (let ((wiki-hr-rx
226         (irregex "^---[-]*[ \\t]*$"))
227        (wiki-header-rx
228         (irregex "^=(=+)[ \\t]*([^=]+)([=]*)$"))
229        (wiki-def-rx
230         (irregex ";[ \\t]+([^:]+)[ \\t]+:[ \\t]+(.*)$"))
231        (wiki-list-level
232         (lambda (str) (string-prefix-length "**********" str)))
233        (make-defns 
234         (lambda (defns)
235           `(dl ,@(map (lambda (x) (list (cons 'dt (wiki-parse-inline (first x)))
236                                         (cons 'dd (wiki-parse-inline (second x)))))
237                       (reverse defns)))))
238        )
239    (lambda (src)
240      (let ((in (if (string? src) (open-input-string src) src)))
241        (let parse ((res '())
242                    (par '())
243                    (list-level 0)
244                    (defns '()))
245          (define (collect)
246            (cond
247             ((null? par)
248              res)
249
250             ((pair? defns)
251              `(,(make-defns defns)  ,@res))
252
253             ((> list-level 0)
254              `((ul ,@(map (lambda (x) (cons 'li (wiki-parse-inline x)))
255                           (reverse par)))
256                ,@res))
257
258             (else
259              `((p
260                 ,@(reverse (drop-while string? par))
261                 ,@(wiki-parse-inline
262                    (string-intersperse
263                     (reverse (take-while string? par))
264                     "\n")))
265                ,@res))))
266          (let ((line (read-line in)))
267            (cond
268
269             ((eof-object? line)
270              (reverse (collect)))
271
272             ((equal? "" line)
273              (cond ((pair? defns)
274                     (parse res (cons (make-defns defns) par) list-level '()))
275                    ((and (pair? par) (safe-assoc 'Section par))
276                     (parse res par list-level defns))
277                    (else
278                     (parse (collect) '() 0 '()))))
279
280             ((irregex-match wiki-hr-rx line)
281              (parse (cons (list 'hr) (collect)) '() 0 '()))
282
283             ((irregex-match wiki-header-rx line)
284              => (lambda (m)
285                   (let* ((h (irregex-match-substring m 1))
286                          (depth (min (string-length h) 6)))
287                     (parse
288                      (collect)
289                      (list (list 'Section depth (irregex-match-substring m 2)))
290                      0
291                      '()))))
292
293             ((irregex-match wiki-def-rx line)
294              => (lambda (m)
295                   (let* ((t (irregex-match-substring m 1))
296                          (d (irregex-match-substring m 2)))
297                     (parse res par list-level (cons (list t d) defns)))))
298
299             ((eqv? #\space (string-ref line 0))
300              (let lp ((ls (list line)))
301                (if (eqv? #\space (peek-char in))
302                    (lp (cons (read-line in) ls))
303                    (let* ((prefix
304                            (fold (lambda (s p)
305                                    (min (string-prefix-length
306                                          (make-string 20 #\space)
307                                          s)
308                                         p))
309                                  20 ls))
310                           ;; strip up to 20 leading space chars
311                           (ls (map (lambda (s) (substring s prefix)) ls)))
312                      (parse
313                       (cons (list 'type (string-intersperse (reverse ls) "\n"))
314                             (collect))
315                       '()
316                       0
317                       defns)))))
318
319
320             (else
321              (let* ((level (wiki-list-level line))
322                     (line (if (zero? level)
323                               line
324                               (string-trim (substring line level)))))
325                (cond
326                 ((= level list-level)
327                  (parse res (cons line par) list-level defns))
328                 (else
329                  (parse (collect) (list line) level defns)))))
330
331             )))))))
332
333)
Note: See TracBrowser for help on using the repository browser.