source: project/release/4/chicken-doc-html/trunk/chicken-doc-html.scm @ 33913

Last change on this file since 33913 was 33913, checked in by zbigniew, 8 months ago

chicken-doc-html: parse sigs more fully, and light up variables and arguments found in {{plaintext}}

File size: 37.7 KB
Line 
1;; FIXME: Some of the match constructs (section, link) can error out if SMXL is malformed
2;; -- they should maybe warn on stderr and dump an error into the document.
3
4(module chicken-doc-html
5(chicken-doc-sxml->html
6 tree->string quote-html text-content
7 quote-identifier unquote-identifier definition->identifier signature->identifier
8 syntax-highlighter colorize prettify-js)
9
10(import scheme chicken)
11(use (only sxml-transforms string->goodHTML SRV:send-reply
12           pre-post-order* universal-conversion-rules*))   ;; temp, for toc
13(use matchable)
14(use (only data-structures conc ->string string-intersperse string-translate alist-ref string-split intersperse))
15(use (only ports with-output-to-string with-input-from-string))
16(use regex) (import irregex)
17(use (only extras sprintf))
18(use (only srfi-13 string-downcase string-index))
19(use (only srfi-1 remove append-map))
20
21(define (sxml-walk doc ss)
22  (let ((default-handler (cond ((assq '*default* ss) => cdr)
23                               (else
24                                (lambda (t b s) (error 'sxml-walk
25                                            "No default binding for" t)))))
26        (text-handler (cond ((assq '*text* ss) => cdr)
27                            (else #f))))
28    (let loop ((doc doc))
29      (cond ((null? doc) '())
30            ((pair? doc)
31             (let ((tag (car doc))
32                   (body (cdr doc)))
33               (if (symbol? tag)
34                   (let ((handler-cell (assq tag ss)))
35                     (if handler-cell
36                         ((cdr handler-cell) tag body ss)
37                         (default-handler tag body ss)))
38                   (map loop doc))))
39            (else
40             (if text-handler
41                 (text-handler '*text* doc ss)
42                 doc))))))
43
44
45(define (tree->string doc)
46  (with-output-to-string (lambda () (SRV:send-reply doc))))
47
48(define (quote-html s)
49  (string->goodHTML s))
50
51;; Like sxpath // *text*.  Beware, if your tags have arguments that
52;; shouldn't be considered text, they will still be extracted.
53(define (text-content doc)
54  (tree->string
55   (sxml-walk doc `((*default* . ,(lambda (t b s) (sxml-walk b s)))
56                    (@ . ,(lambda (t b s) '()))
57                    (*text* . ,(lambda (t b s) b))))))
58
59;;; URI fragment (id=) handling for sections and definitions
60;; Permitted characters in ID attributes in HTML < 5 are only A-Z a-z 0-9 : - _
61;; even though URI fragments are much more liberal.  For compatibility, we
62;; "period-encode" all other chars.
63(define +rx:%idfragment-escape+ (irregex "[^-_:A-Za-z0-9]"))
64(define +rx:%idfragment-unescape+ (irregex "\\.([0-9a-fA-F][0-9a-fA-F])"))
65;; Encode raw identifier text string so it is usable as an HTML 4 ID attribute
66;; (and consequently, as a URI fragment).
67(define (quote-identifier x)  ; Not a good name; should prob. be encode-identifier
68  (irregex-replace/all
69   +rx:%idfragment-escape+ x
70   (lambda (m) (sprintf ".~x"
71                   (char->integer
72                    (string-ref (irregex-match-substring m 0) 0))))))
73;; Decode period-encoded URI fragment (or ID attribute value).
74;; Note that spaces were period-encoded, not converted to underscore,
75;; so the transformation is reversible.
76(define (unquote-identifier x)
77  (irregex-replace/all +rx:%idfragment-unescape+ x
78                       (lambda (m) (string
79                               (integer->char
80                                (string->number (irregex-match-substring m 1)
81                                                16))))))
82;; WARNING: Currently being used to both generate new ids for headers and
83;; to figure out the id for an internal-link target.  However the former may
84;; distinguish duplicate IDs while the latter should ignore duplicates.
85;; FIXME: Duplicate IDs will be generated for duplicate section or
86;; definition names.  A unique suffix is needed.
87(define (section->identifier x)
88  (string-append "sec:"
89                 (string-translate x #\space #\_)))
90(define (definition->identifier x)
91  (string-append "def:" x))
92(define (section->href x)   ;; Convert section name to internal fragment href.
93  (if (string=? x "")
94      ""
95      (string-append "#" (quote-identifier
96                          (section->identifier x)))))
97(define (split-fragment link)    ;; Split at first #
98  (cond ((string-index link #\#)
99         => (lambda (i)
100              (cons (substring link 0 i)
101                    (substring link (+ i 1))))) ; don't include #
102        (else (cons link ""))))
103(define (join-fragment href fragment)  ;; Join with #
104  (if (string=? fragment "")
105      href
106      (string-append href "#" fragment)))
107
108(use (only svnwiki-sxml svnwiki-signature->identifier))
109(define signature->identifier svnwiki-signature->identifier)
110
111;;; Syntax highlighting
112
113;; Highlight SHTML body with LANG syntax and return SHTML or #f.  TAG
114;; is either PRE or CODE (currently only PRE) and indicates our
115;; context; it's probably wise to ignore anything other than PRE
116;; unless the highlighter is super-fast.  Return SHTML *must* be
117;; surrounded with TAG and *should* set 'highlight' class, along with
118;; a class for the particular highlighter used, such as 'colorize' or
119;; 'prettyprint' (prettify.js).  #f return is considered "can't
120;; highlight" and is currently reported as a warning; this is clunky and
121;; we will probably downgrade it to ignore.
122
123;; Highlighters must be prepared to accept SHTML, using text-content
124;; if they require string input (like the colorize egg).  (As we only highlight
125;; plain strings without markup currently, this is for future compatibility.)
126
127;; LANG will generally be the languages supported by the colorize egg
128;; although you may accept additions. LANG #f is not currently
129;; possible (the parser rewrites it to 'scheme) but should be handled
130;; as meaning "figure it out if you can".
131
132(use colorize)       ;; TODO: colorize should be autoloaded.
133(define colorize
134 (lambda (lang tag body)
135   (if (eq? tag 'pre)
136       (and lang (coloring-type-exists? lang)
137            `(,tag (@ (class "highlight colorize"))
138                   (lit ,(html-colorize lang (text-content body)))))
139       `(,tag (@ (class "highlight")) ,body))))
140
141(define prettify-js
142 (lambda (lang tag body)
143   (define (lang->ext L)
144     (alist-ref L
145                '(;; Support out of the box
146                  (c . c) (c++ . cpp) (java . java)
147                  (python . py) (ruby . rb)
148                  (javascript . js) (shell . sh) (json . json)
149                  (html . html) (xhtml . xhtml) (xml . xml)
150                  (coffeescript . coffee) (objective-c . m)
151                  ;; Supported via extensions
152                  (lisp . lisp) (elisp . el) (common-lisp . cl)
153                  (css . css) (sql . sql) (haskell . hs)
154                  (scheme . scm)
155                  ;; Unsupported, but supported by colorize
156                  (erlang . #f) (diff . #f)
157                  )))
158   (if (not (eq? tag 'pre))
159       `(,tag (@ (class "highlight")) ,body)
160       (cond ((lang->ext lang)
161              => (lambda (ext)
162                   `(,tag (@ (class "highlight prettyprint lang-" ,ext))
163                          ,body)))
164             (else #f)))))
165
166(define syntax-highlighter (make-parameter colorize))  ;; Can be #f, which is equivalent to (constantly #f)
167
168;;; HTML renderer
169
170(define +rx:wiki-man-page+ (irregex '(: (? "http://wiki.call-cc.org")
171                                        (or "/man/4/"
172                                            "/manual/")
173                                        (submatch (+ any)))))
174(define +rx:wiki-egg-page+ (irregex '(: (? "http://wiki.call-cc.org")
175                                        (or "/eggref/4/"
176                                            "/egg/")
177                                        (submatch (+ any)))))
178(define (chicken-doc-sxml->html doc
179                                path->href ; for internal links; make parameter?
180                                def->href ; link to definition node, or #f for no link
181                                man-filename->path
182                                )
183  (define (path+section->href p s)
184    (string-append (path->href p) (section->href s)))
185
186  (tree->string
187   (let ((walk sxml-walk)
188         (drop-tag (lambda (t b s) '()))
189         (drop-tag-noisily (lambda (t b s)
190                             ;; Warning disabled as it just spams the logs; instead the
191                             ;; offender could be included in an HTML comment.
192                             ; (warning "dropped" (cons t b))
193                             '()))
194         (quote-text `(*text* . ,(lambda (t b s) (quote-html b))))
195         (sig-args '())) ;; FIXME temp TESTING
196     (letrec ((block (lambda (tag)        ;; could be moved out of letrec, but eh
197                       (let ((open (conc "<" tag ">"))
198                             (close (conc "</" tag ">")))
199                         (lambda (t b s) (list open
200                                          (walk b s)
201                                          close)))))
202              (inline (lambda (tag)
203                        (let ((open (conc "<" tag ">"))
204                              (close (conc "</" tag ">")))
205                          (lambda (t b s) (list open
206                                           (walk b inline-ss)
207                                           close)))))
208              (inline-ss #f))    ;; because we can't rely on letrec* behavior
209       (set!
210        inline-ss `(
211                    ,quote-text
212                    (*default* . ,drop-tag-noisily) ;; 500 error is annoying
213                    (b . ,(inline "b"))
214                    (i . ,(inline "i"))
215                    ;; Conversion of <tt> to <var> is done here, via a fluid-let
216                    (tt . ,(lambda (t b s)
217                             (cond ((not (pair? b)) "")
218                                   ((memq (string->symbol (car b))
219                                          sig-args)
220                                    (sxml->html `(var (@ (class "arg")) ,b)))
221                                   ((def->href (car b)) =>
222                                    (lambda (href)
223                                      ;; def->href generates a direct node
224                                      ;; link, where we might prefer a # link.
225                                      ;; Also, A embedded in VAR is odd, but
226                                      ;; it's easier to style.
227                                      (sxml->html `(var (@ (class "id"))
228                                                        (a (@ (href ,href)) ,b)))))
229                                   (else
230                                    ((inline "tt") t b s)))))
231                    (sup . ,(inline "sup"))
232                    (sub . ,(inline "sub"))
233                    (small . ,(inline "small"))    ;; questionable
234                    (big . ,(inline "big"))        ;; questionable
235                    (img . ,drop-tag)
236                    (code . ,(inline "code"))
237                    (var . ,(inline "var"))
238                    (em . ,(inline "em"))
239                    (strong . ,(inline "strong"))
240                    (& . ,(lambda (t b s) ;; Assume whitelisted at parse time
241                            (map (lambda (e) (string-append "&" e ";"))
242                                 b)))
243                    (link . ,(lambda (t b s)
244                               ;; svnwiki-sxml does not return int-link for
245                               ;; call-cc.org links, so we must check that here.
246                               (define (process-resource R F)
247                                 (cond
248                                  ;; Wiki man page, link to corresponding man page
249                                  ((string-match +rx:wiki-man-page+ R)
250                                   => (lambda (m)
251                                        (cond ((man-filename->path (cadr m))
252                                               => (lambda (p)
253                                                    (path+section->href p F)))
254                                              (else ""))))
255                                  ;; Wiki egg page, link to node
256                                  ((string-match +rx:wiki-egg-page+ R)
257                                   => (lambda (m)
258                                        ;; Split on / for eggs to allow subpage links.
259                                        ;; (Thus we can't link to pages containing a slash; we
260                                        ;; should permit percent encoding in the link.)
261                                        (path+section->href (string-split (cadr m) "/") F)))
262                                  (else (join-fragment R F))))
263                               (let ((do-link
264                                      (lambda (link desc) ;; Caller must quote DESC.
265                                        (let* ((S (split-fragment link))
266                                               (href (process-resource (car S) (cdr S))))
267                                          `("<a href=\"" ,(quote-html href) "\">" ,desc "</a>")))))
268                                 (match b
269                                        ((link desc)
270                                         (do-link link (walk desc inline-ss)))
271                                        ((link)
272                                         (do-link link (quote-html link)))
273                                        (else (error "malformed link" b))))))
274                    (int-link
275                     . ,(lambda (t b s)
276                          (define (process-resource R F) ;; Returns: href
277                            ;; Usage of man-filename->path is barely tolerable.
278                            ;; Perhaps we should use the id cache.
279                            (cond ((string=? R "")
280                                   ;; #fragments target section names in this doc.
281                                   (section->href F))
282                                  ;; Wiki man page, link to corresponding man page,
283                                  ;; or to a dummy URL if man page lookup fails.
284                                  ((string-match +rx:wiki-man-page+ R)
285                                   => (lambda (m)
286                                        (cond ((man-filename->path (cadr m))
287                                               => (lambda (p)
288                                                    (path+section->href p F)))
289                                              (else ""))))
290                                  ;; Wiki egg page, link to node
291                                  ((string-match +rx:wiki-egg-page+ R)
292                                   => (lambda (m)
293                                        (path+section->href (string-split (cadr m) "/")
294                                                            F)))
295                                  ;; Unknown absolute path, link to wiki
296                                  ((char=? (string-ref R 0)
297                                           #\/)
298                                   (join-fragment (string-append "http://wiki.call-cc.org" R)
299                                                  F))
300                                  ;; Relative path, try man page.  Wiki links to
301                                  ;; current directory (/man) but we can't.
302                                  ((man-filename->path R)
303                                   => (lambda (p)
304                                        (path+section->href p F)))
305                                  ;; Relative path, assume egg node.
306                                  (else
307                                   (path+section->href (string-split R "/") F))))
308                          (let ((ilink
309                                 (lambda (link desc) ;; Caller must quote DESC.
310                                   (let* ((S (split-fragment link))
311                                          (href (process-resource (car S) (cdr S))))
312                                     `("<a href=\"" ,(quote-html href) "\">" ,desc "</a>")))))
313                            (match b
314                                   ((link desc) (ilink link (walk desc inline-ss)))
315                                   ((link) (ilink link (quote-html link)))
316                                   (else (error "malformed int-link" b))))))
317                    ))
318       (walk
319        doc
320        `(
321          (p . ,(inline "p"))
322
323          (def
324           . ,(lambda (t b def-ss)
325                ;; FIXME: Setter signatures not handled
326                ;; FIXME handle car=quote
327                ;; FIXME: Handle (?) result shown as -> or => after read object
328                ;; --HANDLED--
329                ;; Optionals after #!optional are handled. They must look like foo or (foo bar).
330                ;; Keywords after #!key are handled. They must look like foo or (foo bar).
331                ;; Rest args after #!rest are handled.
332                ;; Rest args as in (foo . bar) are handled and converted to (foo #!rest bar).
333                ;; Optionals like [foo [bar [baz]] in last position are handled and converted to #!optionals foo bar baz.
334                ;; If a default value for optionals is desired, use #!optionals (foo val).
335                ;; --NOT HANDLED--
336                ;; Optionals like [foo bar baz] (srfi-13) and [foo] [bar] [baz] (sundials) are not allowed and
337                ;;    the signature is rendered unchanged.
338                ;; Keyword optionals like [foo: foo-procedure] (spiffy start-server) or [#:foo 1.0] (srfi-27)
339                ;;   or [#:foo FOO] (setup-helper) or [#:foo FOO #t] or [foo: FOO] (smsmatrix)
340                ;;   or [name [source #f [tag 'locale]]] (locale make-locale-components) are not handled.
341                ;; Arguments can be lowercased, but this is done via CSS.
342               
343                (define (parse-signature sig type)
344                  ;; Testing read/write invariance as strings is problematic because
345                  ;; - 'foo is written as (quote foo)
346                  ;; - #!optional is written as |#!optional|
347                  ;; but we need to render each arg as an HTML string anyway, so it might work
348                  (and (memq type '(procedure parameter constant record setter string))
349                       (let ((L (handle-exceptions exn #f
350                                  (with-input-from-string sig read))))
351                         L)))
352                (define (parse-argument arg dsssl)
353                  (cond ((keyword? arg) #f)
354                        ((symbol? arg)
355                         (case arg
356                           ((#!optional #!key #!rest) `(var (@ (class "dsssl")) ,arg))
357                           ;; Perhaps anything starting with # should be marked as
358                           ;; a keyword or such
359                           (else `(var (@ (class arg)) ,arg))))
360                        ((or (string? arg) (number? arg))
361                         `(var (@ (class value)) ,arg))
362                        ((pair? arg)
363                         (cond ((not (pair? (cdr arg))) #f) ;; never permit (foo . bar)
364                               ((null? (cdr arg)) #f)       ;; Optionals like [foo] were rewritten to #!optionals foo
365                               ((null? (cddr arg))
366                                ;; optional value as (foo 3) -- in an #!optional or #!key clause
367                                (if (eq? (car arg) 'quote)
368                                    (let ((val (cadr arg)))
369                                      (if (or (symbol? val) (string? val) (number? val))
370                                          ;; Render simple values as <var class=value>. We could even do a def->href test
371                                          ;; and render as <var class=id>, but that's unlikely to ever be useful.
372                                          `(var (@ (class value)) #\' ,val)
373                                          `(tt ,(conc #\' val))))
374                                    (and (memq dsssl '(#!optional #!key))
375                                         (and-let* ((key (parse-argument (car arg) '()))
376                                                    (val (parse-argument (cadr arg) '())))
377                                           ;; This will erroneously render val as class arg when val is a plain
378                                           ;; symbol, when it should be class value or, fancily, class id.
379                                           ;; Could do this by changing the dsssl arg to 'mode' and parsing IDs here
380                                           ;; instead of upstream in compute-sig-shtml.
381                                           `(#\( ,key " " ,val #\))))))
382                               (else #f)))
383                        (else
384                         `(tt ,(->string arg)))))
385                (define (parse-optional-arg arg dsssl)
386                  ;; Parse (foo), (foo (bar)), (foo (bar (baz))), ... and return a list of optional args,
387                  ;; or #f if parsing failed. Note: Unlike parse-argument, does not return shtml.
388                  (define (loop acc arg)
389                    (if (and (pair? arg)
390                           (not (keyword? (car arg)))
391                           (symbol? (car arg)))
392                        (cond ((null? (cdr arg))
393                             (reverse (cons (car arg) acc)))
394                            ((and (null? (cddr arg)))
395                             (loop (cons (car arg) acc) (cadr arg)))
396                            (else #f))
397                      #f))
398                  (and (not dsssl)
399                       (loop '() arg)))
400                (define (extract-var-args-from-shtml shtml)
401                  ;; The SHTML is not a proper sexpr markup of the signature. We walk it because
402                  ;; it may not be flat.
403                  (append-map (lambda (b) (match b
404                                            (('var ('@ ('class 'arg)) x)
405                                             (list x))
406                                            ((_ . _)   ; recurse into pair
407                                             (extract-var-args-from-shtml b))
408                                            (else '())))
409                              shtml))
410                (define (compute-sig-shtml sig type)
411                  `(span (@ (class sig)) .
412                         ,(cond ((parse-signature sig type)
413                                 => (lambda (siglist)
414                                      (cond ((not (pair? siglist))
415                                             `((var (@ (class id))
416                                                    ,siglist))) ; might need to check type
417                                            ((match siglist
418                                                    ;; Handle setters. Kinda gross!
419                                                    (('set! (id arg) val)
420                                                     `((var (@ (class dsssl)) set!)   ; meh
421                                                       " ("
422                                                       (var (@ (class id)) ,id)
423                                                       " "
424                                                       ,(parse-argument arg '()) ") "
425                                                       ,(parse-argument val '())))
426                                                    (else #f)))
427                                            ((call/cc (lambda (k) ; rewrite in iterative style pls
428                                                        (let ((shtml 
429                                                               `((var (@ (class "id"))
430                                                                      ,(car siglist)) ; might need to verify is symbol
431                                                                 . ,(let loop ((siglist (cdr siglist))
432                                                                               (dsssl #f))
433                                                                      (cond ((null? siglist) '())
434                                                                            ((pair? siglist)
435                                                                             (let ((dsssl (if (memq (car siglist) '(#!optional #!key #!rest))
436                                                                                              (car siglist) dsssl))) ; hmm
437                                                                               (let ((opt-args
438                                                                                      (and (null? (cdr siglist))
439                                                                                           (parse-optional-arg (car siglist) dsssl))))
440                                                                                 (if opt-args
441                                                                                     (loop (cons '#!optional opt-args) dsssl)
442                                                                                     (cons (or (parse-argument (car siglist) dsssl)
443                                                                                               (k #f))
444                                                                                           (loop (cdr siglist) dsssl))))))
445                                                                            (else
446                                                                             ;; Convert improper list (foo bar . baz) to (foo bar #!rest baz)
447                                                                             (loop `(#!rest ,siglist) dsssl)))))))
448                                                          (intersperse shtml " ")))))
449                                            (else
450                                             `((tt ,sig))))))
451                                (else `((tt ,sig))))))
452
453                (sxml->html
454                 `(dl
455                   (@ (class "defsig"))
456                   ,(match b
457                           ((('sig . sigs) . body)
458                            (let ((args '()))
459                              `(,(map
460                                  (lambda (s)
461                                    (match s
462                                           ((type sig . alist)
463                                            (let* ((defid (cond ((assq 'id alist) => cadr)
464                                                                (else (signature->identifier sig type))))
465                                                   (defid (and defid (->string defid))))
466                                              `(dt (@ (class "defsig")
467                                                      ,(if defid
468                                                           `(id (lit ,(quote-identifier
469                                                                       (definition->identifier defid))))
470                                                           '()))
471                                                   ,(let ((def-href (and defid
472                                                                         (def->href defid))))
473                                                      (let ((sig-span (compute-sig-shtml sig type)))
474                                                        (set! args (append (extract-var-args-from-shtml sig-span)
475                                                                           args)) ;; horrible!
476                                                        (if def-href
477                                                            ;; Link to underlying node, when present.
478                                                            `(a (@ href ,def-href) ,sig-span)
479                                                            sig-span)))
480                                                   (span (@ (class type))
481                                                         ,(->string type)))))
482                                           (else (error "malformed defsig sig" s))))
483                                  sigs)
484                                (dd (@ (class "defsig"))
485                                    (lit ,(fluid-let ((sig-args (append args sig-args))) ;; FIXME
486                                            (walk body def-ss)))))))
487                           (else
488                            (error "malformed defsig" b)))))))
489          (pre . ,(block "pre"))        ; may need to quote contents
490          (ul . ,(lambda (t b ul-ss)
491                   `("<ul>"
492                     ,(walk b `((li
493                                 . ,(lambda (t b s)
494                                      `("<li>"
495                                        ,(walk b ul-ss)
496                                        "</li>\n")))))
497                     "</ul>\n")))
498          (ol . ,(lambda (t b ol-ss)
499                   `("<ol>"
500                     ,(walk b `((li
501                                 . ,(lambda (t b s)
502                                      `("<li>"
503                                        ,(walk b ol-ss)
504                                        "</li>\n")))))
505                     "</ol>\n")))
506          (dl . ,(lambda (t b dl-ss)
507                   `("<dl>"
508                     ,(walk b `((dt . ,(lambda (t b s)
509                                         `("<dt>"
510                                           ,(walk b inline-ss) ;?
511                                           "</dt>\n")))
512                                (dd . ,(lambda (t b s)
513                                         `("<dd>"
514                                           ,(walk b dl-ss)
515                                           "</dd>")))))
516                     "</dl>\n")))
517
518          (tags . ,drop-tag)
519          (toc . ,(lambda (t b s)
520                    (sxml->html (toc doc))))
521          (section . ,(lambda (t b s)
522                        (match b ((level title . body)
523                                  (let ((H (list
524                                            "h" (number->string level)))
525                                        (id (cond ((section->identifier
526                                                    (text-content title))
527                                                   => quote-identifier)
528                                                  (else #f))))
529                                    (list "<" H
530                                          (if id `(" id=\"" ,id "\"") '())
531                                          ">"
532                                          "<a href=\"#" id "\">"
533                                          (walk title inline-ss)
534                                          "</a>"
535                                          "</" H ">"
536                                          (walk body s))))
537                               (else (error "malformed section" b)))))
538
539          (table . ,(lambda (t b table-ss)
540                      ;; Table may be malformed as svnwiki-sxml just passes us the
541                      ;; raw HTML, so we drop bad tags.
542                      `("<table>\n"
543                        ,(walk b `((tr . ,(lambda (t b s)
544                                            `("<tr>"
545                                              ,(walk b
546                                                     (let ((table-ss `((@ . ,drop-tag)
547                                                                       . ,table-ss)))
548                                                       `((th . ,(lambda (t b s)
549                                                                  `("<th>"
550                                                                    ,(walk b table-ss)
551                                                                    "</th>")))
552                                                         (td . ,(lambda (t b s)
553                                                                  `("<td>"
554                                                                    ,(walk b table-ss)
555                                                                    "</td>")))
556                                                         (@ . ,drop-tag)
557                                                         (*default* . ,drop-tag-noisily))))
558                                              "</tr>\n")))
559                                   (@ . ,drop-tag)
560                                   (*default* . ,drop-tag-noisily)))
561                        "</table>\n")))
562
563          ;; colorize supports:
564          ;;  (lisp scheme elisp common-lisp c c++ java objective-c erlang python ruby haskell diff)
565          ;; other suggested syntax names to support:
566          ;;  (javascript shell css html)
567          (highlight . ,(lambda (t b s)
568                          ;; Note: currently in svnwiki-sxml, highlight only has 2 args and body cannot
569                          ;; be a tree, only a string.  However in the future, highlighted code could contain
570                          ;; markup such as links.  We would first convert the body to SHTML; colorizers
571                          ;; must therefore be prepared to accept SHTML, using text-content if they need
572                          ;; string input (like the colorize egg), or passing it through for prettify.js.
573                          ;; (Currently, we cannot transform to SHTML.)
574
575                          ;; lang #f not currently possible, as parser rewrites it to 'scheme; but it
576                          ;;   should be handled here as meaning "figure it out"
577                          ;; syntax-highlighter returns: highlighted SHTML tree, or #f if highlighting failed
578                          ;;   Highlighter should set 'highlight' class in tag, along with a class for
579                          ;;   the particular highlighter used, such as colorize or prettyprint (prettify.js).
580                          (match b ((lang . body)
581                                    (let ((lang (and lang (string->symbol (string-downcase (->string lang)))))
582                                          (type 'pre))
583                                      (sxml->html
584                                       (let ((H (syntax-highlighter)))
585                                         (cond ((and H (H lang type body)))
586                                               (else
587                                                `(,(if lang
588                                                       `((lit "<!-- ")
589                                                         "Unknown coloring type " ,lang
590                                                         (lit " -->"))
591                                                       '())
592                                                  (,type (@ (class "highlight"))
593                                                         ,body))))))))
594                                 (else (error "malformed highlight" b)))))
595
596          ;; convert example contents to `(pre ...) and re-walk it
597         
598          ;; FIXME: The html-parser will erroneously parse html tags
599          ;; inside <expr> tags.  Right now we drop them, but we
600          ;; should either not parse them in the first place or
601          ;; convert them back here (less nice).  Furthermore the parser
602          ;; may unrecoverably screw up the structure of examples, for
603          ;; example if it contains an <h1> tag; therefore we drop unknown
604          ;; tags to prevent a complete rendering error.
605
606          (examples
607           . ,(lambda (t b ex-ss)
608                (walk b `((*default* . ,drop-tag-noisily)
609                          (example
610                           . ,(lambda (t b s)
611                                (walk `(pre
612                                        ,(walk b
613                                               `((init . ,(lambda (t b s)
614                                                            (list b "\n")))
615                                                 (expr . ,(lambda (t b s)
616                                                            (walk b `((*default*
617                                                                       . ,drop-tag-noisily)))))
618                                                 (result . ,(lambda (t b s)
619                                                              `("\n; Result: " ,b)))
620                                                 (*default* . ,drop-tag-noisily))))
621                                      ex-ss)))))))
622
623          (blockquote . ,(block "blockquote"))
624
625          (hr . ,(lambda (t b s)
626                   "<hr />"))
627
628          ,@inline-ss
629          ))))))
630
631(define (sxml->html doc)
632  (with-output-to-string
633    (lambda ()
634      (SRV:send-reply (pre-post-order* doc
635                                       `((*text* . ,(lambda (t b)  ;; Default *text* does not quote symbols, chars, #s.
636                                                      (string->goodHTML (->string b))))
637                                         (lit *preorder* . ,(lambda (t b) b))      ;; should this tree->string?
638                                         . ,universal-conversion-rules*))))))
639
640;; FIXME: Be sure to bench the performance with TOC on.
641(define (toc doc)
642  `(div (@ (id "toc"))
643        (h2 (@ class "toc") "TOC" " " (& "raquo"))
644        (ul (@ class "toc")        ;; set class for compatibility with browsers lacking CSS2 selectors
645            . ,(sxml-walk doc
646                        `((*default* . ,(lambda (t b s) '()))
647                          (section . ,(lambda (t b s)
648                                        (match b ((level title . body)
649                                                  (let ((child (remove null? (sxml-walk body s)))
650                                                        (id (cond ((section->identifier
651                                                                    (text-content title))
652                                                                   => quote-identifier)
653                                                                  (else #f))))
654                                                    `(li ,(if id
655                                                              `(a (@ (href "#" ,id)) ,title)
656                                                              title) 
657                                                         ,(if (null? child)
658                                                              '()
659                                                              `(ul . ,child)))))))))))))
660
661)
Note: See TracBrowser for help on using the repository browser.