source: project/release/4/svnwiki-sxml/trunk/svnwiki-sxml.scm @ 22030

Last change on this file since 22030 was 22030, checked in by Jim Ursetto, 10 years ago

svnwiki-sxml: test-depends test; 0.2.10

File size: 28.9 KB
Line 
1;; todo: handle <blockquote> (see abandoned blockquote branch)
2;; todo: link rendering does not parse inline markup such as {{...}}
3
4(module svnwiki-sxml
5 (svnwiki->sxml
6  svnwiki-signature-parser
7  svnwiki-signature->identifier
8  )
9
10(import scheme chicken)
11(require-library srfi-13 ports data-structures extras)
12(import extras)
13(import (only ports with-input-from-port with-input-from-string))
14(import (only data-structures string-intersperse string-split
15              string-translate* constantly))
16(import (only srfi-13 string-trim string-trim-right string-trim-both
17              string-concatenate-reverse string-index))
18(use regex)
19(use matchable)
20(use html-parser)
21
22(import irregex)
23
24;; (import (rename irregex (irregex irr)))         ; debug
25;; (define (irregex x)
26;;   (display "compiling ")
27;;   (write x)
28;;   (newline)
29;;   (time (irr x)))
30
31(define +identifier-tags+
32    (list "procedure" "macro" "read" "parameter"
33          "record" "string" "class" "method" "constant"
34          "setter" "syntax"))
35
36(define re:header
37  (irregex '(: (submatch (>= 2 #\=)) (+ space) (submatch (+ any)))))
38;; SVNWIKI interprets every character of *#*# and converts this into
39;; ul ol ul ol -- if one char does not match in the next, a new list is
40;; started at that nesting depth.  We currently just rely on the last
41;; character, and only at list open
42(define re:unordered-list
43  (irregex '(: (submatch (* (or #\* #\#)) #\*) (+ space) (submatch (+ any)))))
44(define re:ordered-list
45  (irregex '(: (submatch (* (or #\* #\#)) #\#) (+ space) (submatch (+ any)))))
46(define re:definition-list
47  (irregex '(: #\; (* space)
48               (submatch (* any)))))
49(define sre:preformatted '(: space (submatch (* any))))
50(define re:preformatted (irregex sre:preformatted))
51(define sre:definition-tag
52  `(: #\< (submatch (or ,@+identifier-tags+)) #\>
53               (submatch (: any (*? any)))
54               "</" (backref 1) #\>
55               (* any)))
56(define sre:horizontal-rule '(: "---" (? #\-)))  ; svnwiki is ---- only
57(define re:definition-tag (irregex sre:definition-tag))
58(define re:horizontal-rule (irregex sre:horizontal-rule))
59
60;; This expression is very costly for irregex to compile
61;; (define sre:enscript-tag-start               ; crappy
62;;   '(: "<enscript"
63;;       (? (: space (or "highlight" "language") #\=
64;;             (? (or #\" #\'))
65;;             (submatch (+ (~ (or #\" #\'))))
66;;             (? (or #\" #\'))))
67;;       #\>
68;;       (submatch (* any))))
69
70(define sre:enscript-tag-start
71  '(: #\< "enscript" (submatch (* (~ #\>)))
72      #\> (submatch (* any))))
73
74;; (define sre:tag-attribute            ; compilation ok
75;;   '(: (* space) (submatch (+ alpha)) #\= #\' (submatch (+ (~ #\'))) #\'))
76;; (define sre:tag-attribute            ; compilation very slow
77;;   '(: (* space) (submatch (+ alpha)) #\=
78;;       (or (: #\' (submatch (+ (~ #\'))) #\')
79;;           (: #\" (submatch (+ (~ #\"))) #\")
80;;           (: (submatch (+ (~ space)))))
81;;       ))
82(define sre:tag-attribute                   ; trade compile time for runtime by using greedy
83  '(: (* space) (submatch (+ alpha)) #\=    ; alt: use a multi-fold and no (or ...)
84      (or (: #\' (submatch (*? any)) #\')
85          (: #\" (submatch (*? any)) #\")
86          (: (submatch (+ (~ space)))))))
87(define re:tag-attribute (irregex sre:tag-attribute))
88
89(define sre:nowiki-tag-start '(: "<nowiki>" (submatch (* any))))
90(define re:nowiki-tag-start (irregex sre:nowiki-tag-start))
91(define sre:table-tag-start '(: (submatch "<table" (? #\space) (*? any) #\>)
92                                (submatch (* any))))
93(define sre:examples-tag-start '(: "<examples>" (submatch (* any))))
94(define re:examples-tag-start (irregex sre:examples-tag-start))
95(define re:table-tag-start (irregex sre:table-tag-start))
96(define re:enscript-tag-start (irregex sre:enscript-tag-start))
97(define re:enscript-tag-end (irregex '(: (submatch (* any))
98                                         "</enscript>"
99                                         (submatch (* any)))))
100(define re:nowiki-tag-end (irregex '(: (submatch (* any))
101                                       "</nowiki>"
102                                       (submatch (* any)))))
103(define re:table-tag-end (irregex '(: (submatch (* any))
104                                      "</table>"
105                                      (submatch (* any)))))
106(define re:examples-tag-end (irregex '(: (submatch (* any))
107                                         "</examples>"
108                                         (submatch (* any)))))
109(define sre:directive '(: "[["
110                          (submatch (or "tags" "toc"))
111                          ":"
112                          (submatch (* (~ #\])))
113                          "]]"
114                          (* space)))
115(define re:directive (irregex sre:directive))
116
117(define re:block      ; Should probably use existing REs.
118  (irregex `(or (: (>= 2 #\=) (+ space) (+ any))          ; header
119                (: (+ (or #\* #\#)) (+ space) (+ any))    ; item-list
120                (: #\; (+ any))                           ; definition-list
121                ,sre:preformatted
122;;              ,sre:definition-tag                       ; see below [*]
123                ,sre:horizontal-rule
124                ,sre:enscript-tag-start
125                ,sre:nowiki-tag-start
126                ,sre:table-tag-start
127                ,sre:examples-tag-start
128                ,sre:directive
129             )))
130;; [*] Definition tag relies on backref, but "or" operator throws off
131;; backref numbering indeterminately.  Therefore we disable
132;; definition-tag in re:block; negative effect is that it won't
133;; break us out of current paragraph.  One solution is to make
134;; multiple irregex match calls, one per RE.  Benchmark that.
135
136;; Single-line readahead (effectively, adds peek-line to read-line)
137;; This is a parameter to make it thread-local
138(define *buffered-line* (make-parameter #f))
139(define (read-buffered-line #!optional (p (current-input-port)))
140  ;; NOTE: buffer only works for one port and is not SRFI-18 compatible
141  (let ((b (*buffered-line*)))
142    (cond (b (*buffered-line* #f)
143             b)
144          (else (read-line p)))))
145(define (peek-buffered-line/normal #!optional (p (current-input-port)))
146  (cond ((*buffered-line*))
147        (else
148         (let ((line (read-line p)))
149           (*buffered-line* line)
150           line))))
151(define (peek-buffered-line/debug #!optional (p (current-input-port)))
152  (let ((line   (peek-buffered-line/normal p)))
153    (print "line: " line)
154    line))
155(define peek-buffered-line peek-buffered-line/normal)
156(define (poke-line line #!optional (p (current-input-port)))
157  (*buffered-line* line))
158(define (discard-line #!optional (p (current-input-port)))
159  (*buffered-line* #f))
160
161(define (section-body depth)
162  (let ((line (peek-buffered-line)))
163    (cond ((eof-object? line)
164           '())
165          ((string-match re:header line)
166           => (lambda (m)
167                (let ((next-depth (string-length (cadr m)))
168                      (title (caddr m)))
169                  (cond ((> next-depth depth)
170                         (discard-line)
171                         (let ((title (match (inline title)
172                                             ((t) t)    ; interpolate title when possible
173                                             (t t))))
174                           (let ((sec `(section ,next-depth ,title .
175                                                ,(section-body next-depth))))
176                             (cons sec (section-body depth)))))
177                        (else
178                         '())))))
179          ((string=? line "")
180           (discard-line)
181           (section-body depth))
182          (else (cons (block)
183                      (section-body depth))))))
184
185(define (block)
186  (let ((line (peek-buffered-line)))
187    (cond ((or (string-match re:unordered-list line)
188               (string-match re:ordered-list line)) ; could do simple match here
189           (item-list 0))
190          ((string-match re:definition-list line)
191           (definition-list))
192          ((string-match re:preformatted line)
193           (preformatted))
194          ((string-match re:definition-tag line)
195           (definition-block))
196          ((horizontal-rule? line) => horizontal-rule)
197          ((enscript? line) => enscript)
198          ((nowiki? line)   => nowiki)
199          ((table? line)    => table)
200          ((examples? line) => examples)
201          ((directive? line) => directive)
202          ;; WARNING: If a line is not matched above but does match re:block,
203          ;; then (paragraph) will enter an infinite loop.
204          (else (paragraph)))))
205
206(define (directive? line) (string-match re:directive line))
207(define directive
208  (match-lambda ((_ dir args)
209            (discard-line)
210            (cond ((string=? dir "toc")
211                   `(toc))
212                  ((string=? dir "tags")
213                   `(tags . ,(string-split args)))))))
214(define (horizontal-rule? line) (string-match re:horizontal-rule line))
215(define (horizontal-rule m)
216  (discard-line)
217  '(hr))
218
219(define (parse-attrs str)         ; parse html attributes string, return alist
220  (irregex-fold re:tag-attribute
221                (lambda (i m s)
222                  (cons (cons (string->symbol (irregex-match-substring m 1))
223                              (or (irregex-match-substring m 2)
224                                  (irregex-match-substring m 3)
225                                  (irregex-match-substring m 4)))
226                        s))
227                '() str))
228(define (enscript? line) (string-match re:enscript-tag-start line))
229(define enscript
230  (match-lambda ((_ attrs ln)
231            (discard-line)
232            (let ((attrs (parse-attrs attrs)))
233              (let ((lang (cond ((or (assq 'highlight attrs)
234                                     (assq 'language attrs))
235                                 => (lambda (x) (string->symbol (cdr x))))
236                                (else 'scheme))))
237                `(highlight ,lang
238                            ,(read-verbatim re:enscript-tag-end ln)))))))
239(define (nowiki? line) (string-match re:nowiki-tag-start line))
240(define nowiki
241  (match-lambda ((_ ln)
242            (discard-line)
243            ;; Should be interpolated into result, but we can't do that
244            (cdr (html->sxml (read-verbatim re:nowiki-tag-end ln))))))
245
246(define (examples? line) (string-match re:examples-tag-start line))
247;; Read <examples> block and pass through verbatim to sxml.
248;; There will be some extraneous NLs.
249(define examples
250  (match-lambda ((_ ln)
251            (discard-line)  ; --actually, we don't have to discard, we can just
252                            ; --allow html->sxml to read the entire thing
253            `(examples . ,(cdr (html->sxml
254                                (read-verbatim re:examples-tag-end ln)))))))
255
256;;; table handling
257
258(define (table? line) (string-match re:table-tag-start line))
259(use sxml-transforms)
260(define (pre-post-order-text doc proc)
261  (pre-post-order-splice doc `((*text* . ,(lambda (tag str)
262                                            (proc str)))
263                               (*default* . ,(lambda x x)))))
264
265(define (concatenate-string-fragments L)
266  ;; Intentional: Does not omit empty strings after collapse.
267  (define (str-concat s) ; requires: s is pair
268    (if (null? (cdr L))
269        s                               ; no fresh copy needed
270        (string-concatenate-reverse s)))
271  (define (scons s L)
272    (if (null? s)
273        L
274        (cons (str-concat s) L)))
275  (let rec ((L L) (str '()))
276    (cond ((null? L)
277           (scons str '()))
278          ((pair? (car L))
279           (scons str
280                  (cons (rec (car L) '())
281                        (rec (cdr L) '()))))
282          ((string? (car L))
283           (rec (cdr L)
284                (cons (car L) str)))
285          (else
286           (scons str
287                  (cons (car L)
288                        (rec (cdr L) '())))))))
289
290(define table
291  (match-lambda ((_ tag ln)
292            (discard-line)
293            (let* ((table-str (string-append tag (read-verbatim re:table-tag-end ln)))
294                   (table-sxml (cadr (html->sxml table-str))))
295              ;; Transform inline elements in strings.  char entities open a
296              ;; new string and transform does not work across string boundaries,
297              ;; so first concatenate any adjacent string fragments in the sxml.
298              (pre-post-order-text (concatenate-string-fragments table-sxml)
299                                   inline)))))
300
301;;; block start tag to end tag reading
302
303;; Returns string with NL-delimited lines until end-re
304;; orphaned start and end tags don't count as separate lines
305(define (read-verbatim end-re ln)
306  (unless (string=? ln "")    ;; special handling for orphan start tag
307    (poke-line ln))
308  (string-intersperse (read-until-end-tag end-re)
309                      "\n"))
310(define (read-until-end-tag end-re)  ; returns list of lines
311  (let lp ((lines '()))
312    (let ((line (read-buffered-line)))
313      (cond ((eof-object? line)
314             (reverse lines))
315            ((string-search end-re line)
316             => (match-lambda ((_ pre post)
317                          (poke-line post)
318                          (reverse
319                           (if (string=? pre "") ; special handling for orphan end tag
320                               lines
321                               (cons pre lines))))))
322            ;; NOTE: Abort if we hit a new section?
323            (else
324             (lp (cons line lines)))))))
325
326;;; definitions (procedures, etc.)
327
328(define (definition-block)
329  `(def (sig . ,(definition-sigs))
330        . ,(definition-body)))
331
332(define de-nowikify
333  ;; svnwiki processes HTML tags inside procedure tags.  To insert a
334  ;; literal tag requires <nowiki> + char entity.  Here we convert
335  ;; critical entities to regular text (without fully parsing as HTML).
336  (let ((re (irregex '(: "<nowiki>" (submatch (*? any)) "</nowiki>"))))
337    (define (de-entitize str)
338      (string-translate* str '(("&lt;" . "<")    ("&gt;" . ">")
339                               ("&quot;" . "\"") ("&apos;" . "'")
340                               ("&amp;" . "&"))))
341    (lambda (s)
342      (irregex-replace/all
343       re s
344       (lambda (m) (de-entitize (irregex-match-substring m 1)))))))
345
346;; (def (sig procedure "(foo bar baz)" (id foo)) ...)
347(define (definition-sigs)
348  (define (definition-tag->type tag)
349    (let ((type (string->symbol tag)))
350      (case type
351        ((macro) 'syntax)  ;; convert old svnwiki "macro" tags to "syntax"
352        (else type))))
353  (let ((line (peek-buffered-line)))
354    (cond ((or (eof-object? line)
355               (string=? line ""))
356           (discard-line)
357           '())
358          ((string-match re:definition-tag line)
359           => (match-lambda ((_ tag sig)
360                        (discard-line)
361                        (let* ((type (definition-tag->type tag))
362                               (sig (de-nowikify sig))     ; gosh i hate svnwiki sometimes
363                               (alist ((svnwiki-signature-parser) sig type)))
364                          (let ((alist (if (or (pair? alist)
365                                               (null? alist))
366                                           alist
367                                           `((id ,alist))))) ;; convert id to alist
368                            (cons `(,type
369                                    ,sig
370                                    . ,alist)
371                                  (definition-sigs)))))))
372          (else '()))))
373
374(define (definition-body)
375  (let ((line (peek-buffered-line)))
376    (cond ((eof-object? line) '())
377          ((string=? line "") (discard-line) (definition-body)) ; put in (block)?
378          ((string-match re:header line)
379           '())
380          ((string-match re:definition-tag line)
381           '())
382          ((horizontal-rule? line) '())
383          (else
384           (cons (block)
385                 (definition-body))))))
386
387;;; lists
388
389(define (item-list depth)
390  (let ((line (peek-buffered-line)))
391    (cond ((eof-object? line) '())
392          ((string=? line "")
393           (discard-line)
394           (item-list depth))
395          ((string-match re:unordered-list line)
396           => (lambda (m)
397                (let ((next-depth (string-length (cadr m))))
398                  (cond ((> next-depth depth)
399                         `(ul . ,(item-list-items next-depth)))
400                        (else '())))))
401          ((string-match re:ordered-list line)
402           => (lambda (m)
403                (let ((next-depth (string-length (cadr m))))
404                  (cond ((> next-depth depth)
405                         `(ol . ,(item-list-items next-depth)))
406                        (else '())))))
407          (else '()))))
408
409(define (item-list-items depth)
410  (let ((line (peek-buffered-line)))
411    (cond ((eof-object? line) '())
412          ((string=? line "")
413           (discard-line)
414           (item-list-items depth))
415          ((or (string-match re:unordered-list line)
416               (string-match re:ordered-list line))
417           => (lambda (m)
418                (let ((next-depth (string-length (cadr m)))
419                      (item (caddr m)))
420                  (cond ((> next-depth depth)
421                         (item-list next-depth))
422                        ((= next-depth depth)
423                         (discard-line)
424                         (let ((item (item-list-item (list item))))
425                           (let* ((next-list (item-list next-depth))
426                                  (next-list (if (pair? next-list) ; hack for proper nesting
427                                                 (list next-list) '())))
428                             ;; ITEM is inline not block and should be interpolated.
429                             `((li ,@(inline item) . ,next-list)
430                               . ,(item-list-items depth)))))
431                        (else '())))))
432          (else '()))))
433
434;; List items may extend across lines; read the lines until reaching a block item
435;; and coalesce them.  Special case: initial whitespace does not trigger a PRE block.
436(define (item-list-item lines)
437  (let ((line (peek-buffered-line)))
438    (cond ((or (eof-object? line)
439               (string=? line ""))
440           (discard-line)
441           (string-intersperse (reverse lines) " "))
442          (else
443           (let ((trimmed-line (string-trim-both line)))
444             (cond ((string-match re:block trimmed-line)
445                    (string-intersperse (reverse lines) " "))
446                   (else (discard-line)
447                         (item-list-item (cons trimmed-line lines)))))))))
448
449(define (definition-list)
450  `(dl . ,(definition-list-items)))
451
452(define (definition-list-items)
453  (define (break-pivot pred? then lis)  ;; break list at pred? not including pivot point;
454    (let loop ((L lis) (left '()))      ;; THEN processes pivot and reassembles to (L . R)
455      (cond ((null? L)
456             (cons lis '()))
457            ((pred? (car L))
458             => (lambda (v)
459                  (then v left (car L) (cdr L))))
460            (else
461             (loop (cdr L)
462                   (cons (car L) left))))))
463  (define (unsplit i L p R)
464    (define (split-char str i)  ; split string at index i into cons (before . after)
465      (cons (substring str 0 i)
466            (substring str (+ i 1))))
467    (match-let (((x . y) (split-char p i)))
468      (let ((x (string-trim-right x))
469            (y (string-trim y)))
470        (cons (reverse
471               (if (string=? x "") L (cons x L)))
472              (if (string=? y "") R (cons y R))))))
473  (define (at-colon x)
474    (and (string? x) (string-index x #\:)))
475
476  (let loop ((items '()))
477    (let ((line (peek-buffered-line)))
478      (cond ((eof-object? line)
479             (reverse items))
480            ((string=? line "")
481             (discard-line)
482             (loop items))
483            ((string-match re:definition-list line)
484             => (match-lambda ((_ ln)
485                          (discard-line)
486                          ;; Colons inside inline markup (links, code) must be ignored.
487                          ;; We mark up the entire line, then split the list in two at
488                          ;; the first "naked" colon.
489                          (match-let (((term . def)
490                                       (break-pivot at-colon unsplit (inline ln))))
491                            (loop
492                             (if (null? def)
493                                 `(            (dt . ,term) . ,items)
494                                 `((dd . ,def) (dt . ,term) . ,items)))))))
495            (else (reverse items))))))
496
497;;; pre
498
499(define (preformatted)
500  `(pre ,(slurp-preformatted)))
501(define (slurp-preformatted)
502  (let loop ((lines '()))
503    (let ((line (peek-buffered-line)))
504      (cond ((or (eof-object? line)
505                 (string=? line ""))
506             (discard-line)
507             (string-intersperse (reverse lines) "\n"))
508            ((string-match re:preformatted line)
509             => (match-lambda ((_ text)
510                          (discard-line)
511                          (loop (cons text lines)))))
512            (else
513             (string-intersperse (reverse lines) "\n"))))))
514
515;;; para
516
517(define (paragraph)
518  `(p . ,(inline (slurp-paragraph))))
519(define (slurp-paragraph)
520  (let loop ((lines '()))
521    (let ((line (peek-buffered-line)))
522      (cond ((or (eof-object? line)
523                 (string=? line ""))
524             (discard-line)
525             (string-intersperse (reverse lines) " "))
526            ((string-match re:block line)
527             (string-intersperse (reverse lines) " "))
528            (else (discard-line)
529                  (loop (cons (string-trim-both line) lines)))))))
530
531;;; svnwiki->sxml
532
533(define (svnwiki->sxml in)
534  (discard-line) ; clear buffer
535  (with-input-from-port in
536    (lambda ()
537      (section-body 1))))
538
539#|
540document :: section-body
541section :: section-header section-body
542section-header :: ==+ Title
543section-body :: block* section>*
544
545|#
546
547
548;;; Felix's wiki2html inline parser modified for sxml output
549
550(require-library srfi-1 data-structures)
551(import (only srfi-1 first second third find))
552(import (only data-structures string-translate*))
553
554;; inline elements
555
556;; (define +code+ '(: "{{" (submatch (* (? #\}) (+ (~ #\})))) "}}"))   ;; sjamaan suggestion
557(define +code+ '(: "{{" (submatch (~ #\}) (*? any)) "}}"))
558(define +bold+ '(: "'''" (submatch (~ #\') (*? any)) "'''"))
559(define +italic+ '(: "''" (submatch (~ #\') (*? any)) "''"))
560(define +html-tag+ '(: #\< (submatch (+ (~ #\>))) #\>))
561(define +nowiki+ '(: "<nowiki>" (submatch (*? any)) "</nowiki>"))
562
563(define +link+
564  '(: #\[ #\[ (submatch (* (~ #\] #\|))) (? #\| (submatch (* (~ #\])))) #\] #\]))
565(define +image-link+
566  '(: #\[ #\[ (* space) "image:" (* space)
567      (submatch (* (~ #\] #\|))) (? #\| (submatch (* (~ #\])))) #\] #\]))
568(define +inline-element+
569  `(or ,+code+ ,+image-link+ ,+link+ ;; ,+html-tag+
570       ,+nowiki+
571       ,+bold+ ,+italic+))
572(define +ext-url+ '(: (* space)
573                      (/ "AZaz") (* (or (/ "AZaz09") ("+.-"))) ;; scheme
574                      "://" (* any)))  ;; FIXME: May need to remove // to support mailto:
575
576(define *manual-pages* '())
577(define-constant rx irregex)
578
579;; Parse nowiki contents as html; do no
580;; further parsing for inline elements.
581(define (nowiki-inline str)
582  (cdr (html->sxml str)))
583
584(define (inline/collapse str)
585  ;; INLINE always returns a list, even for a single string.
586  ;; INLINE/COLLAPSE checks for the single string case and lifts it out of the list.
587  ;; This saves a little space in the SXML output when single strings are common,
588  ;; such as in link descriptions.
589  (let ((L (inline str)))
590    (if (and (pair? L)
591             (null? (cdr L))
592             (string? (car L)))
593        (car L)
594        L)))
595
596(define inline
597  (let ((rx:inline-element (rx +inline-element+))
598        (rx:code           (rx `(: bos ,+code+)))
599        (rx:html-tag       (rx `(: ,+html-tag+)))
600        (rx:image-link     (rx `(: bos ,+image-link+)))
601        (rx:link           (rx `(: bos ,+link+)))
602        (rx:ext-url        (rx +ext-url+))
603        (rx:bold           (rx `(: bos ,+bold+)))
604        (rx:italic         (rx `(: bos ,+italic+)))
605        (rx:nowiki         (rx `(: bos ,+nowiki+))))
606    (lambda (str)
607      (let ((m (string-search-positions rx:inline-element str)))
608        (if (not m)
609            (if (string=? str "") '() (list str))
610            (let ((before (substring str 0 (caar m)))
611                  (after
612                   (let ((rest (substring str (caar m))))
613                     (define (continue m)
614                       (inline (substring rest (string-length (first m)))))
615                     (cond ((string-search rx:code rest) =>
616                            (lambda (m)
617                              (cons `(tt ,(second m))
618                                    (continue m))))
619                           ((string-search rx:image-link rest) =>
620                            (lambda (m)
621                              (cons `(image-link ,(second m))
622                                    (continue m))))
623                           ((string-search rx:link rest) =>
624                            (lambda (m)
625                              (let ((href (string-trim-both (second m))) ; ?
626                                    (desc (third m)))
627                                (cons
628                                 (cond
629                                  ((string-match rx:ext-url href)
630                                   (if desc `(link ,href ,(inline/collapse desc)) `(link ,href)))
631                                  ;; Note: internal links ("int-link") make no
632                                  ;;  sense outside of the wiki unless they refer directly
633                                  ;;  to an identifier or egg name.
634                                  ;; Note: Ideally handle #xxx links as node pointers.
635                                  ;; But hard to ensure a node is meant.
636                                  (else
637                                   (if desc `(int-link ,href ,(inline/collapse desc)) `(int-link ,href))))
638                                 (continue m)))))
639                           ((string-search rx:bold rest) =>
640                            (lambda (m)
641                              (cons `(b . ,(inline (second m)))
642                                    (continue m))))
643                           ((string-search rx:italic rest) =>
644                            (lambda (m)
645                              (cons `(i . ,(inline (second m)))
646                                    (continue m))))
647                           ((string-search rx:nowiki rest) =>
648                            (lambda (m)
649                              (append (nowiki-inline (second m))
650                                      (continue m))))
651                           (else (error "unknown inline match" m rest))))))
652              (if (string=? before "")
653                  after
654                  (cons before after)))
655             
656             
657            )
658
659        ))))
660
661;;; signature parsing
662
663;; Function of two args, SIG and TYPE, called for each definition.  Should return either a pair
664;; (an alist) or an identifier.  This result is inserted into the
665;; defsig clause.  The only current defined alist key is "id", whose
666;; value is the identifier for this signature, or #f on parse failure.
667;; Non-pair returns (identifiers) are changed into the alist `((id ,id)).
668;; A null alist indicates no processing was done at svnwiki parse time,
669;; effectively indicating the user should parse it if desired.
670(define svnwiki-signature-parser
671  (make-parameter (constantly '())))
672
673;; Convert signature string (usually a list or bare identifier) into an identifier.
674;; Returns a symbol, a string, or #f.
675;; We read the string with the scheme reader.  If a list, take the car recursively.
676;; If a symbol, return the symbol.  If any other scheme object, return the whole
677;; signature string.   If it cannot be read as a scheme expression, return #f.
678;; As a special case, read syntax returns the entire signature without trying
679;; to read it first; note this may cause a problem with older Chicken versions
680;; due to r/w variance with symbols starting with #.
681;; Also note that results of parsing a keyword identifier are undefined.
682(define svnwiki-signature->identifier
683  (let ((+rx:ivanism+ (irregex '(: ":" eos))))
684    (lambda (sig type)
685      (if (eq? type 'read)
686          sig
687          (condition-case
688           (let loop ((id (with-input-from-string sig read))
689                      (in-pair #f))
690             (cond ((pair? id) (loop (car id) #t))
691                   ((keyword? id)
692                    (if in-pair
693                        id ;; Returned as symbol, but ->string will drop any colons.
694                        ;; SPECIAL HANDLING: handle e.g. MPI:init:: -> MPI:init,
695                        ;; only at toplevel of signature (not nested in a pair).
696                        ;; Remove this once these signatures are normalized.
697                        ;; (Warning: when read as a keyword, symbol->string
698                        ;;  will strip one : itself).  We assume keywords are
699                        ;; in suffix style.
700                        (let ((str (irregex-replace +rx:ivanism+
701                                                    (symbol->string id)
702                                                    "")))
703                          (if str (string->symbol str) id))))
704                   ((symbol? id) id)
705                   (else sig)))
706           ((exn) #f))))))
707
708)
709
Note: See TracBrowser for help on using the repository browser.