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

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

Do not make headings part of paragraphs

File size: 13.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-procedure-rx
133         (irregex "<procedure>([^<]+)</procedure>"))
134        (wiki-constant-rx
135         (irregex "<constant>([^<]+)</constant>"))
136        (wiki-parameter-rx
137         (irregex "<parameter>([^<]+)</parameter>"))
138        (wiki-macro-rx
139         (irregex "<macro>([^<]+)</macro>"))
140        (wiki-type-rx
141         (irregex "\\{\\{([^\\}]+)\\}\\}")) 
142        (wiki-center-rx
143         (irregex "<center>([^<]+)</center>"))
144        (wiki-blockquote-rx
145         (irregex "<blockquote>([^<]+)</blockquote>"))
146        (wiki-uline-rx
147         (irregex "<u>([^<]+)</u>"))
148        (wiki-strike-out-rx
149         (irregex "<s>([^<]+)</s>"))
150        (wiki-table-rx
151         (irregex "\\{\\|(.*)\n((?:\\|[^}]|[^|])*)\\|\\}"))
152        (wiki-row-rx
153         (irregex "\n\\|- *"))
154        (wiki-col-rx
155         (irregex "\\|\\|"))
156        (wiki-named-url-rx
157         (irregex "\\[\\[((?:https?|ftp):/+[\\-+.,_/%?&~=:\\w]+[\\-+_/%?&~=:\\w])\\|[ \t\n]*([^\\]]*)\\]\\]"))
158        (wiki-url-rx
159         (irregex "((?:https?|ftp):/+[\\-+.,_/%?&~=:\\w]+[\\-+_/%?&~=:\\w])"))
160        (wiki-special-rx
161         (irregex "\\[\\[([a-z]+):([^\\]]*)\\]\\]"))       
162        (wiki-word-rx
163         (irregex "\\[\\[([^\\]|]+)(?:\\| *([^\\]|]+))?\\]\\]")))
164    (lambda (str)
165      (irregex-multi-fold
166       `((,wiki-table-rx
167          ,(lambda (m)
168             (append
169              (car
170               (html->sxml
171                (string-append
172                 "<table "
173                 (or (irregex-match-substring m 1) "")
174                 ">")))
175              (map (lambda (row)
176                     (cons 'tr
177                           (map (lambda (col)
178                                  (cons 'td
179                                        (wiki-parse-inline
180                                         (string-trim-both col))))
181                                (irregex-split
182                                 wiki-col-rx
183                                 (string-trim
184                                  row
185                                  (lambda (c)
186                                    (or (char-whitespace? c) (eqv? c #\|))))))))
187                   (irregex-split
188                    wiki-row-rx
189                    (string-append "\n" (irregex-match-substring m 2)))))))
190         (,wiki-procedure-rx
191          ,(lambda (m) (list 'definition 'procedure
192                             (irregex-match-substring m 1))))
193         (,wiki-constant-rx
194          ,(lambda (m) (list 'definition 'constant
195                             (irregex-match-substring m 1))))
196         (,wiki-macro-rx
197          ,(lambda (m) (list 'definition 'macro
198                             (irregex-match-substring m 1))))
199         (,wiki-parameter-rx
200          ,(lambda (m) (list 'definition 'parameter
201                             (irregex-match-substring m 1))))
202         (,wiki-type-rx
203          ,(lambda (m)
204             (list 'type
205                   (wiki-parse-inline (irregex-match-substring m 1))
206                   #f)))
207         (,wiki-named-url-rx
208          ,(lambda (m)
209             (list 'url
210                   (irregex-match-substring m 1)
211                   (irregex-match-substring m 2))))
212         (,wiki-url-rx
213          ,(lambda (m)
214             (list 'url
215                   (irregex-match-substring m 1)
216                   (irregex-match-substring m 1))))
217         (,wiki-special-rx
218          ,(lambda (m) (list 'special (string->symbol (irregex-match-substring m 1))
219                             (string-trim-both (irregex-match-substring m 2)))))
220         (,wiki-word-rx
221          ,(lambda (m)
222             (list 'wiki
223                   (irregex-match-substring m 1)
224                   (irregex-match-substring m 2))))
225         (,wiki-blockquote-rx
226          ,(lambda (m) (list 'blockquote (irregex-match-substring m 1))))
227         (,wiki-small-rx
228          ,(lambda (m) (list 'small (irregex-match-substring m 1))))
229         (,wiki-big-rx
230          ,(lambda (m) (list 'big (irregex-match-substring m 1))))
231         (,wiki-center-rx
232          ,(lambda (m) (list 'center (irregex-match-substring m 1))))
233         (,wiki-bold-rx
234          ,(lambda (m) (list 'b (irregex-match-substring m 1))))
235         (,wiki-italic-rx
236          ,(lambda (m) (list 'i (irregex-match-substring m 1))))
237         (,wiki-uline-rx
238          ,(lambda (m) (list 'u (irregex-match-substring m 1))))
239         (,wiki-strike-out-rx
240          ,(lambda (m) (list 's (irregex-match-substring m 1))))
241         )
242       str))))
243
244(define wiki-parse
245  (let ((wiki-hr-rx
246         (irregex "^---[-]*[ \\t]*$"))
247        (wiki-header-rx
248         (irregex "^=(=+)[ \\t]*([^=]+)([=]*)$"))
249        (wiki-def-rx
250         (irregex ";[ \\t]+([^:]+)[ \\t]+:[ \\t]+(.*)$"))
251        (wiki-nowiki-start-rx
252         (irregex "<nowiki>(.*)"))
253        (wiki-nowiki-end-rx
254         (irregex "(.*)</nowiki>"))
255        (wiki-list-level
256         (lambda (str) (string-prefix-length "**********" str)))
257        (make-defns 
258         (lambda (defns)
259           `(dl ,@(map (lambda (x) (list (cons 'dt (wiki-parse-inline (first x)))
260                                         (cons 'dd (wiki-parse-inline (second x)))))
261                       (reverse defns)))))
262        )
263    (lambda (src)
264      (let ((in (if (string? src) (open-input-string src) src)))
265        (let parse ((res '())
266                    (par '())
267                    (list-level 0)
268                    (defns '()))
269          (define (collect)
270            (cond
271             ((null? par)
272              res)
273
274             ((pair? defns)
275              `(,(make-defns defns)  ,@res))
276
277             ((> list-level 0)
278              `((ul ,@(map (lambda (x) (cons 'li (wiki-parse-inline x)))
279                           (reverse par)))
280                ,@res))
281
282             (else
283              `(,@(reverse (drop-while string? par))
284                ,@(let ((inline
285                         (wiki-parse-inline
286                          (string-intersperse
287                           (reverse (take-while string? par))
288                           "\n"))))
289                    (if (null? inline)
290                        '()
291                        `((p ,@inline))))
292                ,@res))))
293          (let ((line (read-line in)))
294            (cond
295
296             ((eof-object? line)
297              (reverse (collect)))
298
299             ((equal? "" line)
300              (cond ((pair? defns)
301                     (parse res (cons (make-defns defns) par) list-level '()))
302                    ((and (pair? par) (safe-assoc 'Section par))
303                     (parse res par list-level defns))
304                    (else
305                     (parse (collect) '() 0 '()))))
306
307             ((irregex-match wiki-hr-rx line)
308              (parse (cons (list 'hr) (collect)) '() 0 '()))
309
310             ((irregex-match wiki-header-rx line)
311              => (lambda (m)
312                   (let* ((h (irregex-match-substring m 1))
313                          (depth (min (string-length h) 6)))
314                     (parse
315                      (collect)
316                      (list (list 'Section depth (irregex-match-substring m 2)))
317                      0
318                      '()))))
319
320             ((irregex-match wiki-def-rx line)
321              => (lambda (m)
322                   (let* ((t (irregex-match-substring m 1))
323                          (d (irregex-match-substring m 2)))
324                     (parse res par list-level (cons (list t d) defns)))))
325
326             ((irregex-match wiki-nowiki-start-rx line)
327              => (lambda (m)
328                   (let nw ((txt "")
329                            (ln (irregex-match-substring m 1)))
330                     (cond
331                      ((eof-object? ln)
332                       (parse (cons (list 'nowiki txt) (collect)) '() 0 defns))
333                      ((irregex-match wiki-nowiki-end-rx ln)
334                       => (lambda (n)
335                            (parse
336                             (cons (list 'nowiki
337                                         (string-append
338                                          txt (irregex-match-substring n 1)))
339                                   (collect)) '() 0 defns)))
340                      (else (nw (string-append txt ln) (read-line in)))))))
341             
342             ((eqv? #\space (string-ref line 0))
343              (let lp ((ls (list line)))
344                (if (eqv? #\space (peek-char in))
345                    (lp (cons (read-line in) ls))
346                    (let* ((prefix
347                            (fold (lambda (s p)
348                                    (min (string-prefix-length
349                                          (make-string 20 #\space)
350                                          s)
351                                         p))
352                                  20 ls))
353                           ;; strip up to 20 leading space chars
354                           (ls (map (lambda (s) (substring s prefix)) ls)))
355                      (parse
356                       (cons (list 'preformatted
357                                   (string-intersperse (reverse ls) "\n"))
358                             (collect))
359                       '()
360                       0
361                       defns)))))
362
363
364             (else
365              (let* ((level (wiki-list-level line))
366                     (line (if (zero? level)
367                               line
368                               (string-trim (substring line level)))))
369                (cond
370                 ((= level list-level)
371                  (parse res (cons line par) list-level defns))
372                 (else
373                  (parse (collect) (list line) level defns)))))
374
375             )))))))
376
377)
Note: See TracBrowser for help on using the repository browser.