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

Last change on this file since 15456 was 15456, checked in by Ivan Raikov, 11 years ago

streamlining of wiki link parsing; added some simle test cases

File size: 13.9 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 and Peter Bex.
6;;
7;; Copyright 2009 Alex Shinn, Ivan Raikov, Peter Bex.
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)
49        (require-extension html-parser uri-common)
50
51(define (safe-assoc k lst)
52  (and (pair? lst) (or (and (pair? (car lst)) (eq? k (caar lst)) (caar lst)) 
53                       (safe-assoc k (cdr lst)))))
54 
55
56;; translate a wiki word to a safe pathname (after escaping, colons
57;; ':' are translated to slashes '/' to create a diretory hierarchy of
58;; wiki words)
59(define wiki-word-encode
60  (let ((wiki-unsafe-rx (irregex "[^!--0-Z^-~]")))
61    (lambda (str)
62      (string-translate
63       (irregex-replace/all
64        wiki-unsafe-rx
65        str
66        (lambda (m)
67          (let ((n (char->integer (string-ref (irregex-match-substring m) 0))))
68            (string-append "_" (if (< n 16) "0" "")
69                           (string-upcase (number->string n 16))))))
70       ":"
71       "/"))))
72
73;; reverse the above
74(define wiki-word-decode
75  (let ((wiki-escaped-rx (irregex "_([0-9a-fA-F][0-9a-fA-F])")))
76    (lambda (str)
77      (irregex-replace/all
78       wiki-escaped-rx
79       (string-translate str "/" ":")
80       (lambda (m)
81         (string
82          (integer->char
83           (string->number (irregex-match-substring m 1) 16))))))))
84
85(define (%irregex-multi-fold ls str start end)
86  (cond
87   ((null? ls)
88    (if (>= start end) '() (list (substring str start end))))
89   (else
90    (irregex-fold
91     (caar ls)
92     (lambda (i m x)
93       (let ((left (%irregex-multi-fold (cdr ls) str i (irregex-match-start m)))
94             (right (reverse (irregex-apply-match m (cdar ls)))))
95         (append x left right)))
96     '()
97     str
98     (lambda (i x)
99       (append x (%irregex-multi-fold (cdr ls) str i end)))
100     start
101     end))))
102
103(define (irregex-multi-fold ls str . o)
104  (let ((start (if (pair? o) (car o) 0))
105        (end (if (and (pair? o) (pair? (cdr o)))
106                 (cadr o)
107                 (string-length str))))
108    (%irregex-multi-fold ls str start end)))
109
110(define (irregex-split irx str)
111  (reverse
112   (irregex-fold
113    irx
114    (lambda (i m x)
115      (let ((j (irregex-match-start m)))
116        (if (> j i) (cons (substring str i j) x) x)))
117    '()
118    str
119    (lambda (i x)
120      (if (< i (- (string-length str) 1))
121          (cons (substring str i) x)
122          x)))))
123
124(define wiki-parse-inline
125  (let ((wiki-bold-rx
126         (irregex "'''([^']+)'''")) 
127        (wiki-italic-rx
128         (irregex "''([^']+)''"))
129        (wiki-big-rx
130         (irregex "<big>([^<]+)</big>"))
131        (wiki-small-rx
132         (irregex "<small>([^<]+)</small>"))
133        (wiki-procedure-rx
134         (irregex "<procedure>([^<]+)</procedure>"))
135        (wiki-constant-rx
136         (irregex "<constant>([^<]+)</constant>"))
137        (wiki-parameter-rx
138         (irregex "<parameter>([^<]+)</parameter>"))
139        (wiki-macro-rx
140         (irregex "<macro>([^<]+)</macro>"))
141        (wiki-type-rx
142         (irregex "\\{\\{([^\\}]+)\\}\\}")) 
143        (wiki-center-rx
144         (irregex "<center>([^<]+)</center>"))
145        (wiki-blockquote-rx
146         (irregex "<blockquote>([^<]+)</blockquote>"))
147        (wiki-uline-rx
148         (irregex "<u>([^<]+)</u>"))
149        (wiki-strike-out-rx
150         (irregex "<s>([^<]+)</s>"))
151        (wiki-table-rx
152         (irregex "\\{\\|(.*)\n((?:\\|[^}]|[^|])*)\\|\\}"))
153        (wiki-row-rx
154         (irregex "\n\\|- *"))
155        (wiki-col-rx
156         (irregex "\\|\\|"))
157        (wiki-link-rx
158         (irregex "(\\[\\[)((([^\\|\\]])+)((\\|)([^\\]]+))*)(\\]\\])"))
159        (wiki-special-rx
160         (irregex "([^:]+)(:)(.*)"))
161        )
162    (lambda (str)
163      (irregex-multi-fold
164       `((,wiki-table-rx
165          ,(lambda (m)
166             (append
167              (car
168               (html->sxml
169                (string-append
170                 "<table "
171                 (or (irregex-match-substring m 1) "")
172                 ">")))
173              (map (lambda (row)
174                     (cons 'tr
175                           (map (lambda (col)
176                                  (cons 'td
177                                        (wiki-parse-inline
178                                         (string-trim-both col))))
179                                (irregex-split
180                                 wiki-col-rx
181                                 (string-trim
182                                  row
183                                  (lambda (c)
184                                    (or (char-whitespace? c) (eqv? c #\|))))))))
185                   (irregex-split
186                    wiki-row-rx
187                    (string-append "\n" (irregex-match-substring m 2)))))))
188         (,wiki-procedure-rx
189          ,(lambda (m) (list 'definition 'procedure
190                             (irregex-match-substring m 1))))
191         (,wiki-constant-rx
192          ,(lambda (m) (list 'definition 'constant
193                             (irregex-match-substring m 1))))
194         (,wiki-macro-rx
195          ,(lambda (m) (list 'definition 'macro
196                             (irregex-match-substring m 1))))
197         (,wiki-parameter-rx
198          ,(lambda (m) (list 'definition 'parameter
199                             (irregex-match-substring m 1))))
200         (,wiki-type-rx
201          ,(lambda (m)
202             (list 'type
203                   (wiki-parse-inline (irregex-match-substring m 1))
204                   #f)))
205
206         (,wiki-link-rx
207          ,(lambda (m)
208             (let ((m2 (irregex-match-substring m 2))
209                   (m3 (irregex-match-substring m 3))
210                   (m7 (or (irregex-match-substring m 7) "")))
211               (cond ((uri-reference m3) =>
212                      ;; Case 1: wiki-link is a possible URI reference
213                      (lambda (u)
214                        ;; If the wiki-link is a valid URI,
215                        ;; then it could be an absolute URI,
216                        ;; a local wiki link,
217                        ;; or a special tag of the form [[tag: value]]
218                        (if (relative-ref? u)
219                            ;; Case 1.1: the URI does not contain any
220                            ;; scheme  (relative reference)
221                            (list 'wiki m3 m7)
222                            ;; Case 1.2: the URI is absolute, or a special tag
223                            (case (uri-scheme u)
224                              ;; Case 1.2.1: the URI contains a valid scheme name
225                              ((http https ftp)
226                               (list 'url m3 m7)) 
227                              ;; Case 1.2.2: the URI does not contain a
228                              ;; valid scheme name, and is therefore a
229                              ;; special tag
230                              (else (list 'special (uri-scheme u)
231                                          (string-trim-both m7)))))))
232                     ;; Case 2: wiki-link is not a valid URI; if the
233                     ;; link-name contains colon, we treat it as a
234                     ;; special tag, otherwise as a link to a local
235                     ;; wiki page
236                     (else
237                      (cond ((irregex-search wiki-special-rx m2) =>
238                             (lambda (m) 
239                               (list 'special (string->symbol (irregex-match-substring m 1))
240                                     (string-trim-both (irregex-match-substring m 3)))))
241                            (else (list 'wiki m3 m7)))))
242                     )))
243
244         (,wiki-blockquote-rx
245          ,(lambda (m) (list 'blockquote (irregex-match-substring m 1))))
246         (,wiki-small-rx
247          ,(lambda (m) (list 'small (irregex-match-substring m 1))))
248         (,wiki-big-rx
249          ,(lambda (m) (list 'big (irregex-match-substring m 1))))
250         (,wiki-center-rx
251          ,(lambda (m) (list 'center (irregex-match-substring m 1))))
252         (,wiki-bold-rx
253          ,(lambda (m) (list 'b (irregex-match-substring m 1))))
254         (,wiki-italic-rx
255          ,(lambda (m) (list 'i (irregex-match-substring m 1))))
256         (,wiki-uline-rx
257          ,(lambda (m) (list 'u (irregex-match-substring m 1))))
258         (,wiki-strike-out-rx
259          ,(lambda (m) (list 's (irregex-match-substring m 1))))
260         )
261       str))))
262
263(define wiki-parse
264  (let ((wiki-hr-rx
265         (irregex "^---[-]*[ \\t]*$"))
266        (wiki-header-rx
267         (irregex "^=(=+)[ \\t]*([^=]+)([=]*)$"))
268        (wiki-def-rx
269         (irregex ";[ \\t]+(\\[\\[.*\\]\\]|([^:]+))[ \\t]+:[ \\t]+(.*)$"))
270        (wiki-nowiki-start-rx
271         (irregex "<nowiki>(.*)"))
272        (wiki-nowiki-end-rx
273         (irregex "(.*)</nowiki>"))
274        (wiki-list-level
275         (lambda (str) (string-prefix-length "**********" str)))
276        (make-defns 
277         (lambda (defns)
278           `(dl ,@(map (lambda (x) (list (cons 'dt (wiki-parse-inline (first x)))
279                                         (cons 'dd (wiki-parse-inline (second x)))))
280                       (reverse defns)))))
281        )
282    (lambda (src)
283      (let ((in (if (string? src) (open-input-string src) src)))
284        (let parse ((res '())
285                    (par '())
286                    (list-level 0)
287                    (defns '()))
288          (define (collect)
289            (cond
290             ((null? par)
291              res)
292
293             ((pair? defns)
294              `(,(make-defns defns)  ,@res))
295
296             ((> list-level 0)
297              `((ul ,@(map (lambda (x) (cons 'li (wiki-parse-inline x)))
298                           (reverse par)))
299                ,@res))
300
301             (else
302              `(,@(reverse (drop-while string? par))
303                ,@(let ((inline
304                         (wiki-parse-inline
305                          (string-intersperse
306                           (reverse (take-while string? par))
307                           "\n"))))
308                    (if (null? inline)
309                        '()
310                        `((p ,@inline))))
311                ,@res))))
312          (let ((line (read-line in)))
313            (cond
314
315             ((eof-object? line)
316              (reverse (collect)))
317
318             ((equal? "" line)
319              (cond ((pair? defns)
320                     (parse res (cons (make-defns defns) par) list-level '()))
321                    ((and (pair? par) (safe-assoc 'Section par))
322                     (parse res par list-level defns))
323                    (else
324                     (parse (collect) '() 0 '()))))
325
326             ((irregex-match wiki-hr-rx line)
327              (parse (cons (list 'hr) (collect)) '() 0 '()))
328
329             ((irregex-match wiki-header-rx line)
330              => (lambda (m)
331                   (let* ((h (irregex-match-substring m 1))
332                          (depth (min (string-length h) 6)))
333                     (parse
334                      (collect)
335                      (list (list 'Section depth (irregex-match-substring m 2)))
336                      0
337                      '()))))
338
339             ((irregex-match wiki-def-rx line)
340              => (lambda (m)
341                   (let* ((t (irregex-match-substring m 1))
342                          (d (irregex-match-substring m 3)))
343                     (parse res par list-level (cons (list t d) defns)))))
344
345             ((irregex-match wiki-nowiki-start-rx line)
346              => (lambda (m)
347                   (let nw ((txt "")
348                            (ln (irregex-match-substring m 1)))
349                     (cond
350                      ((eof-object? ln)
351                       (parse (cons (list 'nowiki txt) (collect)) '() 0 defns))
352                      ((irregex-match wiki-nowiki-end-rx ln)
353                       => (lambda (n)
354                            (parse
355                             (cons (list 'nowiki
356                                         (string-append
357                                          txt (irregex-match-substring n 1)))
358                                   (collect)) '() 0 defns)))
359                      (else (nw (string-append txt ln) (read-line in)))))))
360             
361             ((eqv? #\space (string-ref line 0))
362              (let lp ((ls (list line)))
363                (if (eqv? #\space (peek-char in))
364                    (lp (cons (read-line in) ls))
365                    (let* ((prefix
366                            (fold (lambda (s p)
367                                    (min (string-prefix-length
368                                          (make-string 20 #\space)
369                                          s)
370                                         p))
371                                  20 ls))
372                           ;; strip up to 20 leading space chars
373                           (ls (map (lambda (s) (substring s prefix)) ls)))
374                      (parse
375                       (cons (list 'preformatted
376                                   (string-intersperse (reverse ls) "\n"))
377                             (collect))
378                       '()
379                       0
380                       defns)))))
381
382
383             (else
384              (let* ((level (wiki-list-level line))
385                     (line (if (zero? level)
386                               line
387                               (string-trim (substring line level)))))
388                (cond
389                 ((= level list-level)
390                  (parse res (cons line par) list-level defns))
391                 (else
392                  (parse (collect) (list line) level defns)))))
393
394             )))))))
395
396)
Note: See TracBrowser for help on using the repository browser.