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

Last change on this file since 29554 was 29554, checked in by zbigniew, 4 years ago

chicken-doc-html 0.2.7: Fix for letrec behavior change in 4.8.3

File size: 27.2 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))
15(use (only ports with-output-to-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))
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;; distinuish 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     (letrec ((block (lambda (tag)        ;; could be moved out of letrec, but eh
196                       (let ((open (conc "<" tag ">"))
197                             (close (conc "</" tag ">")))
198                         (lambda (t b s) (list open
199                                          (walk b s)
200                                          close)))))
201              (inline (lambda (tag)
202                        (let ((open (conc "<" tag ">"))
203                              (close (conc "</" tag ">")))
204                          (lambda (t b s) (list open
205                                           (walk b inline-ss)
206                                           close)))))
207              (inline-ss #f))    ;; because we can't rely on letrec* behavior
208       (set!
209        inline-ss `(
210                    ,quote-text
211                    (*default* . ,drop-tag-noisily) ;; 500 error is annoying
212                    (b . ,(inline "b"))
213                    (i . ,(inline "i"))
214                    (tt . ,(inline "tt"))
215                    (sup . ,(inline "sup"))
216                    (sub . ,(inline "sub"))
217                    (small . ,(inline "small"))    ;; questionable
218                    (big . ,(inline "big"))        ;; questionable
219                    (img . ,drop-tag)
220                    (code . ,(inline "code"))
221                    (var . ,(inline "var"))
222                    (em . ,(inline "em"))
223                    (strong . ,(inline "strong"))
224                    (& . ,(lambda (t b s) ;; Assume whitelisted at parse time
225                            (map (lambda (e) (string-append "&" e ";"))
226                                 b)))
227                    (link . ,(lambda (t b s)
228                               ;; svnwiki-sxml does not return int-link for
229                               ;; call-cc.org links, so we must check that here.
230                               (define (process-resource R F)
231                                 (cond
232                                  ;; Wiki man page, link to corresponding man page
233                                  ((string-match +rx:wiki-man-page+ R)
234                                   => (lambda (m)
235                                        (cond ((man-filename->path (cadr m))
236                                               => (lambda (p)
237                                                    (path+section->href p F)))
238                                              (else ""))))
239                                  ;; Wiki egg page, link to node
240                                  ((string-match +rx:wiki-egg-page+ R)
241                                   => (lambda (m)
242                                        ;; Split on / for eggs to allow subpage links.
243                                        ;; (Thus we can't link to pages containing a slash; we
244                                        ;; should permit percent encoding in the link.)
245                                        (path+section->href (string-split (cadr m) "/") F)))
246                                  (else (join-fragment R F))))
247                               (let ((do-link
248                                      (lambda (link desc) ;; Caller must quote DESC.
249                                        (let* ((S (split-fragment link))
250                                               (href (process-resource (car S) (cdr S))))
251                                          `("<a href=\"" ,(quote-html href) "\">" ,desc "</a>")))))
252                                 (match b
253                                        ((link desc)
254                                         (do-link link (walk desc inline-ss)))
255                                        ((link)
256                                         (do-link link (quote-html link)))
257                                        (else (error "malformed link" b))))))
258                    (int-link
259                     . ,(lambda (t b s)
260                          (define (process-resource R F) ;; Returns: href
261                            ;; Usage of man-filename->path is barely tolerable.
262                            ;; Perhaps we should use the id cache.
263                            (cond ((string=? R "")
264                                   ;; #fragments target section names in this doc.
265                                   (section->href F))
266                                  ;; Wiki man page, link to corresponding man page,
267                                  ;; or to a dummy URL if man page lookup fails.
268                                  ((string-match +rx:wiki-man-page+ R)
269                                   => (lambda (m)
270                                        (cond ((man-filename->path (cadr m))
271                                               => (lambda (p)
272                                                    (path+section->href p F)))
273                                              (else ""))))
274                                  ;; Wiki egg page, link to node
275                                  ((string-match +rx:wiki-egg-page+ R)
276                                   => (lambda (m)
277                                        (path+section->href (string-split (cadr m) "/")
278                                                            F)))
279                                  ;; Unknown absolute path, link to wiki
280                                  ((char=? (string-ref R 0)
281                                           #\/)
282                                   (join-fragment (string-append "http://wiki.call-cc.org" R)
283                                                  F))
284                                  ;; Relative path, try man page.  Wiki links to
285                                  ;; current directory (/man) but we can't.
286                                  ((man-filename->path R)
287                                   => (lambda (p)
288                                        (path+section->href p F)))
289                                  ;; Relative path, assume egg node.
290                                  (else
291                                   (path+section->href (string-split R "/") F))))
292                          (let ((ilink
293                                 (lambda (link desc) ;; Caller must quote DESC.
294                                   (let* ((S (split-fragment link))
295                                          (href (process-resource (car S) (cdr S))))
296                                     `("<a href=\"" ,(quote-html href) "\">" ,desc "</a>")))))
297                            (match b
298                                   ((link desc) (ilink link (walk desc inline-ss)))
299                                   ((link) (ilink link (quote-html link)))
300                                   (else (error "malformed int-link" b))))))
301                    ))
302       (walk
303        doc
304        `(
305          (p . ,(inline "p"))
306
307          (def
308           . ,(lambda (t b def-ss)
309                `("<dl class=\"defsig\">"
310                  ,(match b
311                          ((('sig . sigs) . body)
312                           `(,(map
313                               (lambda (s)
314                                 (match s
315                                        ((type sig . alist)
316                                         (let* ((defid (cond ((assq 'id alist) => cadr)
317                                                             (else (signature->identifier sig type))))
318                                                (defid (and defid (->string defid))))
319                                           `("<dt class=\"defsig\""
320                                             ,(if defid
321                                                  `(" id=\""
322                                                    ,(quote-identifier
323                                                      (definition->identifier defid))
324                                                    #\")
325                                                  '())
326                                             #\>
327                                             ;; Link to underlying node.
328                                             ,(let ((def-href (and defid
329                                                                   (def->href defid))))
330                                                `(,(if def-href
331                                                       `("<a href=\"" ,def-href "\">")
332                                                       '())
333                                                  "<span class=\"sig\"><tt>"
334                                                  ,(quote-html sig) "</tt></span>"
335                                                  ,(if def-href "</a>" '())))
336                                             " "
337                                             "<span class=\"type\">"
338                                             ,(quote-html (->string type))
339                                             "</span>"
340                                             "</dt>\n")))
341                                        (else (error "malformed defsig sig" s))))
342                               sigs)
343                             "<dd class=\"defsig\">"
344                             ,(walk body def-ss)
345                             "</dd>\n"))
346                          (else
347                           (error "malformed defsig" b)))
348                  "</dl>\n")))
349          (pre . ,(block "pre"))        ; may need to quote contents
350          (ul . ,(lambda (t b ul-ss)
351                   `("<ul>"
352                     ,(walk b `((li
353                                 . ,(lambda (t b s)
354                                      `("<li>"
355                                        ,(walk b ul-ss)
356                                        "</li>\n")))))
357                     "</ul>\n")))
358          (ol . ,(lambda (t b ol-ss)
359                   `("<ol>"
360                     ,(walk b `((li
361                                 . ,(lambda (t b s)
362                                      `("<li>"
363                                        ,(walk b ol-ss)
364                                        "</li>\n")))))
365                     "</ol>\n")))
366          (dl . ,(lambda (t b dl-ss)
367                   `("<dl>"
368                     ,(walk b `((dt . ,(lambda (t b s)
369                                         `("<dt>"
370                                           ,(walk b inline-ss) ;?
371                                           "</dt>\n")))
372                                (dd . ,(lambda (t b s)
373                                         `("<dd>"
374                                           ,(walk b dl-ss)
375                                           "</dd>")))))
376                     "</dl>\n")))
377
378          (tags . ,drop-tag)
379          (toc . ,(lambda (t b s)
380                    (sxml->html (toc doc))))
381          (section . ,(lambda (t b s)
382                        (match b ((level title . body)
383                                  (let ((H (list
384                                            "h" (number->string level)))
385                                        (id (cond ((section->identifier
386                                                    (text-content title))
387                                                   => quote-identifier)
388                                                  (else #f))))
389                                    (list "<" H
390                                          (if id `(" id=\"" ,id "\"") '())
391                                          ">"
392                                          "<a href=\"#" id "\">"
393                                          (walk title inline-ss)
394                                          "</a>"
395                                          "</" H ">"
396                                          (walk body s))))
397                               (else (error "malformed section" b)))))
398
399          (table . ,(lambda (t b table-ss)
400                      ;; Table may be malformed as svnwiki-sxml just passes us the
401                      ;; raw HTML, so we drop bad tags.
402                      `("<table>\n"
403                        ,(walk b `((tr . ,(lambda (t b s)
404                                            `("<tr>"
405                                              ,(walk b
406                                                     (let ((table-ss `((@ . ,drop-tag)
407                                                                       . ,table-ss)))
408                                                       `((th . ,(lambda (t b s)
409                                                                  `("<th>"
410                                                                    ,(walk b table-ss)
411                                                                    "</th>")))
412                                                         (td . ,(lambda (t b s)
413                                                                  `("<td>"
414                                                                    ,(walk b table-ss)
415                                                                    "</td>")))
416                                                         (@ . ,drop-tag)
417                                                         (*default* . ,drop-tag-noisily))))
418                                              "</tr>\n")))
419                                   (@ . ,drop-tag)
420                                   (*default* . ,drop-tag-noisily)))
421                        "</table>\n")))
422
423          ;; colorize supports:
424          ;;  (lisp scheme elisp common-lisp c c++ java objective-c erlang python ruby haskell diff)
425          ;; other suggested syntax names to support:
426          ;;  (javascript shell css html)
427          (highlight . ,(lambda (t b s)
428                          ;; Note: currently in svnwiki-sxml, highlight only has 2 args and body cannot
429                          ;; be a tree, only a string.  However in the future, highlighted code could contain
430                          ;; markup such as links.  We would first convert the body to SHTML; colorizers
431                          ;; must therefore be prepared to accept SHTML, using text-content if they need
432                          ;; string input (like the colorize egg), or passing it through for prettify.js.
433                          ;; (Currently, we cannot transform to SHTML.)
434
435                          ;; lang #f not currently possible, as parser rewrites it to 'scheme; but it
436                          ;;   should be handled here as meaning "figure it out"
437                          ;; syntax-highlighter returns: highlighted SHTML tree, or #f if highlighting failed
438                          ;;   Highlighter should set 'highlight' class in tag, along with a class for
439                          ;;   the particular highlighter used, such as colorize or prettyprint (prettify.js).
440                          (match b ((lang . body)
441                                    (let ((lang (and lang (string->symbol (string-downcase (->string lang)))))
442                                          (type 'pre))
443                                      (sxml->html
444                                       (let ((H (syntax-highlighter)))
445                                         (cond ((and H (H lang type body)))
446                                               (else
447                                                `(,(if lang
448                                                       `((lit "<!-- ")
449                                                         "Unknown coloring type " ,lang
450                                                         (lit " -->"))
451                                                       '())
452                                                  (,type (@ (class "highlight"))
453                                                         ,body))))))))
454                                 (else (error "malformed highlight" b)))))
455
456          ;; convert example contents to `(pre ...) and re-walk it
457         
458          ;; FIXME: The html-parser will erroneously parse html tags
459          ;; inside <expr> tags.  Right now we drop them, but we
460          ;; should either not parse them in the first place or
461          ;; convert them back here (less nice).  Furthermore the parser
462          ;; may unrecoverably screw up the structure of examples, for
463          ;; example if it contains an <h1> tag; therefore we drop unknown
464          ;; tags to prevent a complete rendering error.
465
466          (examples
467           . ,(lambda (t b ex-ss)
468                (walk b `((*default* . ,drop-tag-noisily)
469                          (example
470                           . ,(lambda (t b s)
471                                (walk `(pre
472                                        ,(walk b
473                                               `((init . ,(lambda (t b s)
474                                                            (list b "\n")))
475                                                 (expr . ,(lambda (t b s)
476                                                            (walk b `((*default*
477                                                                       . ,drop-tag-noisily)))))
478                                                 (result . ,(lambda (t b s)
479                                                              `("\n; Result: " ,b)))
480                                                 (*default* . ,drop-tag-noisily))))
481                                      ex-ss)))))))
482
483          (blockquote . ,(block "blockquote"))
484
485          (hr . ,(lambda (t b s)
486                   "<hr />"))
487
488          ,@inline-ss
489          ))))))
490
491(define (sxml->html doc)
492  (with-output-to-string
493    (lambda ()
494      (SRV:send-reply (pre-post-order* doc
495                                       `((*text* . ,(lambda (t b)  ;; Default *text* does not quote symbols, chars, #s.
496                                                      (string->goodHTML (->string b))))
497                                         (lit *preorder* . ,(lambda (t b) b))      ;; should this tree->string?
498                                         . ,universal-conversion-rules*))))))
499
500;; FIXME: Be sure to bench the performance with TOC on.
501(define (toc doc)
502  `(div (@ (id "toc"))
503        (h2 (@ class "toc") "TOC" " " (& "raquo"))
504        (ul (@ class "toc")        ;; set class for compatibility with browsers lacking CSS2 selectors
505            . ,(sxml-walk doc
506                        `((*default* . ,(lambda (t b s) '()))
507                          (section . ,(lambda (t b s)
508                                        (match b ((level title . body)
509                                                  (let ((child (remove null? (sxml-walk body s)))
510                                                        (id (cond ((section->identifier
511                                                                    (text-content title))
512                                                                   => quote-identifier)
513                                                                  (else #f))))
514                                                    `(li ,(if id
515                                                              `(a (@ (href "#" ,id)) ,title)
516                                                              title) 
517                                                         ,(if (null? child)
518                                                              '()
519                                                              `(ul . ,child)))))))))))))
520
521)
Note: See TracBrowser for help on using the repository browser.