source: project/release/5/chicken-doc-html/trunk/chicken-doc-html.scm @ 35721

Last change on this file since 35721 was 35721, checked in by felix, 7 weeks ago

chicken-doc-html 0.3.1 for C5

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