scribble extensions to support the new docs

svn: r6248

original commit: 1df44725567621dfc64bdd14de426f8d23d91eaf

collects/scribble/base-render.ss

@@ -0,0 +1,265 @@
+
+(module base-render mzscheme
+  (require "struct.ss"
+           (lib "class.ss")
+           (lib "serialize.ss")
+           (lib "file.ss"))
+
+  (provide render%)
+
+  (define render%
+    (class object%
+
+      (init-field dest-dir)
+      
+      (define/public (get-dest-directory)
+        dest-dir)
+
+      (define/public (get-substitutions) null)
+      
+      (define/public (get-suffix) #".txt")
+
+      (define/public (format-number number sep)
+        (if (or (null? number)
+                (andmap not number))
+            null
+            (cons
+             (apply
+              string-append
+              (map (lambda (n) 
+                     (if n
+                         (format "~s." n)
+                         ""))
+                   (reverse number)))
+             sep)))
+
+      ;; ----------------------------------------
+      ;; global-info collection
+
+      (define/public (save-info fn info)
+        (let ([s (serialize info)])
+          (with-output-to-file fn
+            (lambda ()
+              (write s))
+            'truncate/replace)))
+
+      (define/public (load-info fn info)
+        (let ([ht (deserialize (with-input-from-file fn read))])
+          (hash-table-for-each ht (lambda (k v)
+                                    (hash-table-put! info k v))))
+        info)
+      
+      (define/public (collect ds fns)
+        (let ([ht (make-hash-table 'equal)])
+          (map (lambda (d)
+                 (collect-part d #f ht null))
+               ds)
+          ht))
+
+      (define/public (collect-part d parent ht number)
+        (let ([p-ht (make-hash-table 'equal)])
+          (when (part-title-content d)
+            (collect-content (part-title-content d) p-ht))
+          (when (part-tag d)
+            (collect-part-tag d p-ht))
+          (collect-flow (part-flow d) p-ht)
+          (let loop ([parts (part-parts d)]
+                     [pos 1])
+            (unless (null? parts)
+              (let ([s (car parts)])
+                (collect-part s d p-ht
+                              (cons (if (unnumbered-part? s)
+                                        #f
+                                        pos)
+                                    number))
+                (loop (cdr parts)
+                      (if (unnumbered-part? s) pos (add1 pos))))))
+          (set-part-collected-info! d (make-collected-info
+                                       number
+                                       parent
+                                       p-ht))
+          (hash-table-for-each p-ht
+                               (lambda (k v)
+                                 (hash-table-put! ht k v)))))
+
+      (define/public (collect-part-tag d ht)
+        (hash-table-put! ht `(part ,(part-tag d)) (part-title-content d)))
+      
+      (define/public (collect-content c ht)
+        (for-each (lambda (i)
+                    (collect-element i ht))
+                  c))
+
+      (define/public (collect-paragraph p ht)
+        (collect-content (paragraph-content p) ht))
+
+      (define/public (collect-flow p ht)
+        (for-each (lambda (p)
+                    (collect-flow-element p ht))
+                  (flow-paragraphs p)))
+
+      (define/public (collect-flow-element p ht)
+        (cond
+         [(table? p) (collect-table p ht)]
+         [(itemization? p) (collect-itemization p ht)]
+         [(delayed-flow-element? p) (void)]
+         [else (collect-paragraph p ht)]))
+        
+      (define/public (collect-table i ht)
+        (for-each (lambda (d) (collect-flow d ht))
+                  (apply append (table-flowss i))))
+      
+      (define/public (collect-itemization i ht)
+        (for-each (lambda (d) (collect-flow d ht))
+                  (itemization-flows i)))
+
+      (define/public (collect-element i ht)
+        (when (target-element? i)
+          (collect-target-element i ht))
+        (when (index-element? i)
+          (collect-index-element i ht))
+        (when (element? i)
+          (for-each (lambda (e)
+                      (collect-element e ht))
+                    (element-content i))))
+
+      (define/public (collect-target-element i ht)
+        (hash-table-put! ht (target-element-tag i) i))
+
+      (define/public (collect-index-element i ht)
+        (hash-table-put! ht `(index-entry ,(index-element-tag i))
+                         (list (index-element-plain-seq i)
+                               (index-element-entry-seq i))))
+
+      ;; ----------------------------------------
+      ;; render methods
+
+      (define/public (render ds fns ht)
+        (map (lambda (d fn)
+               (printf " [Output to ~a]\n" fn)
+               (with-output-to-file fn
+                 (lambda ()
+                   (render-one d ht fn))
+                 'truncate/replace))
+
+             ds
+             fns))
+               
+      (define/public (render-one d ht fn)
+        (render-part d ht))
+
+      (define/public (render-part d ht)
+        (list
+         (when (part-title-content d)
+           (render-content (part-title-content d) d ht))
+         (render-flow (part-flow d) d ht)
+         (map (lambda (s) (render-part s ht))
+              (part-parts d))))
+      
+      (define/public (render-content c part ht)
+        (apply append
+               (map (lambda (i)
+                      (render-element i part ht))
+                    c)))
+
+      (define/public (render-paragraph p part ht)
+        (render-content (paragraph-content p) part ht))
+
+      (define/public (render-flow p part ht)
+        (apply append
+               (map (lambda (p)
+                      (render-flow-element p part ht))
+                    (flow-paragraphs p))))
+
+      (define/public (render-flow-element p part ht)
+        (cond
+         [(table? p) (render-table p part ht)]
+         [(itemization? p) (render-itemization p part ht)]
+         [(delayed-flow-element? p) (render-flow-element
+                                     ((delayed-flow-element-render p) this part ht)
+                                     part ht)]
+         [else (render-paragraph p part ht)]))
+        
+      (define/public (render-table i part ht)
+        (map (lambda (d) (render-flow d part ht)) 
+             (apply append (table-flowss i))))
+      
+      (define/public (render-itemization i part ht)
+        (map (lambda (d) (render-flow d part ht))
+             (itemization-flows i)))
+      
+      (define/public (render-element i part ht)
+        (cond
+         [(and (link-element? i)
+               (null? (element-content i)))
+          (let ([v (hash-table-get ht (link-element-tag i) #f)])
+            (if v
+                (render-content v part ht)
+                (render-content (list "[missing]") part ht)))]
+         [(element? i)
+          (render-content (element-content i) part ht)]
+         [(delayed-element? i)
+          (render-content (force-delayed-element i this part ht) part ht)]
+         [else
+          (render-other i part ht)]))
+
+      (define/public (render-other i part ht)
+        (list i))
+
+      ;; ----------------------------------------
+
+      (define/public (install-file fn)
+        (let ([src-dir (path-only fn)]
+              [dest-dir (get-dest-directory)]
+              [fn (file-name-from-path fn)])
+          (let ([src-file (build-path (or src-dir (current-directory))
+                                      fn)]
+                [dest-file (build-path (or dest-dir (current-directory))
+                                       fn)])
+            (unless (and (file-exists? dest-file)
+                         (call-with-input-file* 
+                          src-file
+                          (lambda (src)
+                            (call-with-input-file* 
+                             dest-file
+                             (lambda (dest)
+                               (or (equal? (port-file-identity src)
+                                           (port-file-identity dest))
+                                   (let loop ()
+                                     (let ([s (read-bytes 4096 src)]
+                                           [d (read-bytes 4096 dest)])
+                                       (and (equal? s d)
+                                            (if (eof-object? s)
+                                                #t
+                                                (loop)))))))))))
+              (when (file-exists? dest-file) (delete-file dest-file))
+              (copy-file src-file dest-file))
+            (path->string fn))))
+
+      ;; ----------------------------------------
+
+      (define/public (table-of-contents part ht)
+        (make-table #f (cdr (render-toc part))))
+
+      (define/private (render-toc part)
+        (let ([number (collected-info-number (part-collected-info part))])
+          (cons
+           (list (make-flow
+                  (list
+                   (make-paragraph
+                    (list
+                     (make-element 'hspace (list (make-string (* 2 (length number)) #\space)))
+                     (make-link-element "toclink"
+                                        (append
+                                         (format-number number 
+                                                        (list
+                                                         (make-element 'hspace '(" "))))
+                                         (part-title-content part))
+                                        `(part ,(part-tag part))))))))
+           (apply
+            append
+            (map (lambda (p) (render-toc p)) (part-parts part))))))
+
+      ;; ----------------------------------------
+      
+      (super-new))))

collects/scribble/basic.ss

@@ -0,0 +1,189 @@
+
+(module basic mzscheme
+  (require "decode.ss"
+           "struct.ss"
+           "config.ss"
+           (lib "kw.ss")
+           (lib "list.ss")
+           (lib "class.ss"))
+  
+  (provide title 
+           section
+           subsection
+           subsubsection
+           subsubsub*section
+           include-section)
+
+  (define (gen-tag content)
+    (regexp-replace* "[^-a-zA-Z0-9_=]" 
+                     (content->string content)
+                     "_"))
+
+  (define/kw (title #:key [tag #f] #:body str)
+    (let ([content (decode-content str)])
+      (make-title-decl (or tag (gen-tag content)) content)))
+  
+  (define/kw (section #:key [tag #f] #:body str)
+    (let ([content (decode-content str)])
+      (make-part-start 0 (or tag (gen-tag content)) content)))
+
+  (define/kw (subsection #:key [tag #f] #:body str)
+    (let ([content (decode-content str)])
+      (make-part-start 1 (or tag (gen-tag content)) content)))
+
+  (define/kw (subsubsection #:key [tag #f] #:body str)
+    (let ([content (decode-content str)])
+      (make-part-start 2 (or tag (gen-tag content)) content)))
+
+  (define/kw (subsubsub*section #:key [tag #f] #:body str)
+    (let ([content (decode-content str)])
+      (make-paragraph (list (make-element 'bold content)))))
+
+  (define-syntax include-section 
+    (syntax-rules ()
+      [(_ mod)
+       (begin
+         (require (only mod doc))
+         doc)]))
+
+  ;; ----------------------------------------
+
+  (provide itemize item item?)
+
+  (define/kw (itemize #:body items)
+    (let ([items (filter (lambda (v) (not (whitespace? v))) items)])
+      (for-each (lambda (v)
+                  (unless (an-item? v)
+                    (error 'itemize
+                           "expected an item, found something else: ~e"
+                           v)))
+                items)
+      (make-itemization (map an-item-flow items))))
+
+  (define-struct an-item (flow))
+  (define (item? x) (an-item? x))
+
+  (define/kw (item #:body str)
+    (make-an-item (decode-flow str)))
+
+  ;; ----------------------------------------
+
+  (provide hspace
+           elem
+           italic bold
+           tt span-class
+           subscript superscript)
+
+  (define (hspace n)
+    (make-element 'hspace (list (make-string n #\space))))
+
+  (define/kw (elem #:body str)
+    (make-element #f (decode-content str)))
+
+  (define/kw (italic #:body str)
+    (make-element 'italic (decode-content str)))
+
+  (define/kw (bold #:body str)
+    (make-element 'bold (decode-content str)))
+
+  (define/kw (tt #:body str)
+    (make-element 'tt (decode-content str)))
+
+  (define/kw (span-class classname #:body str)
+    (make-element classname (decode-content str)))
+
+  (define/kw (subscript #:body str)
+    (make-element 'subscript (decode-content str)))
+
+  (define/kw (superscript #:body str)
+    (make-element superscript (decode-content str)))
+
+  ;; ----------------------------------------
+
+  (provide index index* as-index index-section)
+
+  (define (gen-target)
+    (format "index:~s:~s" (current-seconds) (gensym)))
+  
+  (define (record-index word-seq element-seq tag content)
+    (make-index-element
+     #f
+     (list (make-target-element #f content tag))
+     tag
+     word-seq
+     element-seq))
+
+  (define/kw (index* word-seq content-seq #:body s)
+    (let ([key (gen-target)])
+      (record-index word-seq
+                    content-seq
+                    key
+                    (decode-content s))))
+
+  (define/kw (index word-seq #:body s)
+    (let ([word-seq (if (string? word-seq)
+                        (list word-seq)
+                        word-seq)])
+      (apply index* word-seq word-seq s)))
+
+  (define/kw (as-index #:body s)
+    (let ([key (gen-target)]
+          [content (decode-content s)])
+      (record-index (list (content->string content))
+                    (list (make-element #f content)) 
+                    key
+                    content)))
+
+  (define (index-section tag)
+    (make-unnumbered-part
+     tag
+     (list "Index")
+     #f
+     (make-flow (list (make-delayed-flow-element
+                       (lambda (renderer sec ht)
+                         (let ([l null])
+                           (hash-table-for-each 
+                            (collected-info-info 
+                             (part-collected-info
+                              (collected-info-parent
+                               (part-collected-info sec))))
+                            (lambda (k v)
+                              (if (and (pair? k)
+                                       (eq? 'index-entry (car k)))
+                                  (set! l (cons (cons (cadr k) v) l)))))
+                           (let ([l (sort 
+                                     l
+                                     (lambda (a b)
+                                       (let loop ([a (cadr a)][b (cadr b)])
+                                         (cond
+                                          [(null? a) #t]
+                                          [(null? b) #f]
+                                          [(string-ci=? (car a) (car b))
+                                           (loop (cdr a) (cdr b))]
+                                          [else
+                                           (string-ci<? (car a) (car b))]))))])
+                             (make-table
+                              'index
+                              (map (lambda (i)
+                                     (list (make-flow
+                                            (list
+                                             (make-paragraph
+                                              (list
+                                               (make-link-element
+                                                #f
+                                                (caddr i)
+                                                (car i))))))))
+                                   l))))))))
+     null))
+
+  ;; ----------------------------------------
+
+  (provide table-of-contents)
+
+  (define (table-of-contents)
+    (make-delayed-flow-element
+     (lambda (renderer part ht)
+       (send renderer table-of-contents part ht)))))
+
+
+

collects/scribble/bnf.ss

@@ -0,0 +1,74 @@
+
+(module bnf mzscheme
+  (require "struct.ss"
+           "decode.ss"
+           (lib "kw.ss")
+           (lib "class.ss"))
+
+  (provide BNF 
+           nonterm
+           BNF-seq
+           BNF-alt ; single-lie alternatives
+           BNF-etc
+           BNF-group
+           optional kleenestar kleeneplus kleenerange)
+
+  (define spacer (make-element 'hspace (list " ")))
+  (define equals (make-element 'tt (list spacer "::=" spacer)))
+  (define alt (make-element 'tt (list spacer spacer "|" spacer spacer)))
+
+  (define (as-flow i) (make-flow (list (make-paragraph (list i)))))
+
+  (define (BNF . defns)
+    (make-table
+     #f
+     (apply
+      append
+      (map (lambda (defn)
+             (cons
+              (list (as-flow spacer) (as-flow (car defn)) (as-flow equals) (as-flow (cadr defn)))
+              (map (lambda (i)
+                     (list (as-flow spacer) (as-flow " ") (as-flow alt) (as-flow i)))
+                   (cddr defn))))
+           defns))))
+
+  (define (interleave l spacer)
+    (make-element #f (cons (car l)
+                           (apply append
+                                  (map (lambda (i)
+                                         (list spacer i))
+                                       (cdr l))))))
+
+  (define (BNF-seq . l)
+    (if (null? l)
+        ""
+        (interleave l spacer)))
+
+  (define (BNF-alt . l)
+    (interleave l alt))
+
+  (define BNF-etc "...")
+
+  (define/kw (nonterm #:body s)
+    (make-element #f (append (list "<") 
+                             (list (make-element 'italic (decode-content s)))
+                             (list ">"))))
+
+  (define/kw (optional #:body s)
+    (make-element #f (append (list "[") (decode-content s) (list "]"))))
+
+  (define/kw (BNF-group #:body s)
+    (make-element #f (append (list "{") 
+                             (list (apply BNF-seq (decode-content s)))
+                             (list "}"))))
+
+  (define/kw (kleenestar #:body s)
+    (make-element #f (append (decode-content s) (list "*"))))
+
+  (define/kw (kleeneplus #:body s)
+    (make-element #f (append (decode-content s) (list (make-element 'superscript (list "+"))))))
+
+  (define/kw (kleenerange a b #:body s)
+    (make-element #f (append (decode-content s) 
+                             (list (make-element 'superscript 
+                                                 (list (format "{~a,~a}" a b))))))))

collects/scribble/config.ss

@@ -0,0 +1,6 @@
+
+(module config mzscheme
+
+  (provide value-color)
+
+  (define value-color "DarkBlue"))

collects/scribble/decode.ss

@@ -0,0 +1,178 @@
+
+(module decode mzscheme
+  (require "struct.ss"
+           (lib "contract.ss")
+           (lib "class.ss"))
+
+  (provide decode
+           decode-part
+           decode-flow
+           decode-paragraph
+           decode-content
+           decode-string
+           whitespace?)
+
+  (provide-structs
+   [title-decl ([tag any/c]
+                [content list?])]
+   [part-start ([depth integer?]
+                [tag (or/c false/c string?)]
+                [title list?])]
+   [splice ([run list?])])
+
+  (define (decode-string s)
+    (let loop ([l '((#rx"---" mdash)
+                    (#rx"--" ndash)
+                    (#rx"``" ldquo)
+                    (#rx"''" rdquo)
+                    (#rx"'" rsquo))])
+      (cond
+       [(null? l) (list s)]
+       [(regexp-match-positions (caar l) s)
+	=> (lambda (m)
+	     (append (decode-string (substring s 0 (caar m)))
+		     (cdar l)
+		     (decode-string (substring s (cdar m)))))]
+       [else (loop (cdr l))])))
+
+  (define (line-break? v)
+    (and (string? v)
+         (equal? v "\n")))
+
+  (define (whitespace? v)
+    (and (string? v)
+         (regexp-match #px"^[\\s]*$" v)))
+
+  (define (decode-accum-para accum)
+    (if (andmap whitespace? accum)
+        null
+        (list (decode-paragraph (reverse (skip-whitespace accum))))))
+
+  (define (decode-flow* l tag title part-depth)
+    (let loop ([l l][next? #f][accum null][title title][tag tag])
+      (cond
+       [(null? l) (make-part tag
+                             title 
+                             #f
+                             (make-flow (decode-accum-para accum))
+                             null)]
+       [(title-decl? (car l))
+        (unless part-depth
+          (error 'decode
+                 "misplaced title: ~e"
+                 (car l)))
+        (when title
+          (error 'decode
+                 "found extra title: ~v"
+                 (car l)))
+        (loop (cdr l) next? accum (title-decl-content (car l)) (title-decl-tag (car l)))]
+       [(or (paragraph? (car l))
+            (table? (car l))
+            (itemization? (car l))
+            (delayed-flow-element? (car l)))
+        (let ([para (decode-accum-para accum)]
+              [part (decode-flow* (cdr l) tag title part-depth)])
+          (make-part (part-tag part)
+                     (part-title-content part)
+                     (part-collected-info part)
+                     (make-flow (append para
+                                        (list (car l)) 
+                                        (flow-paragraphs (part-flow part))))
+                     (part-parts part)))]
+       [(part? (car l))
+        (let ([para (decode-accum-para accum)]
+              [part (decode-part (cdr l) tag title part-depth)])
+          (make-part (part-tag part)
+                     (part-title-content part)
+                     (part-collected-info part)
+                     (make-flow (append para
+                                        (flow-paragraphs
+                                         (part-flow part))))
+                     (cons (car l) (part-parts part))))]
+       [(and (part-start? (car l))
+             (or (not part-depth)
+                 ((part-start-depth (car l)) . <= . part-depth)))
+        (unless part-depth
+          (error 'decode
+                 "misplaced part: ~e"
+                 (car l)))
+        (let ([s (car l)])
+          (let loop ([l (cdr l)]
+                     [s-accum null])
+            (if (or (null? l)
+                    (or (and (part-start? (car l))
+                             ((part-start-depth (car l)) . <= . part-depth))
+                        (part? (car l))))
+                (let ([para (decode-accum-para accum)]
+                      [s (decode-part (reverse s-accum)
+                                      (part-start-tag s)
+                                      (part-start-title s)
+                                      (add1 part-depth))]
+                      [part (decode-part l tag title part-depth)])
+                  (make-part (part-tag part)
+                             (part-title-content part)
+                             (part-collected-info part)
+                             (make-flow para)
+                             (cons s (part-parts part))))
+                (loop (cdr l) (cons (car l) s-accum)))))]
+       [(splice? (car l))
+	(loop (append (splice-run (car l)) (cdr l)) next? accum title tag)]
+       [(null? (cdr l)) (loop null #f (cons (car l) accum) title tag)]
+       [(and (pair? (cdr l))
+	     (splice? (cadr l)))
+	(loop (cons (car l) (append (splice-run (cadr l)) (cddr l))) next? accum title tag)]
+       [(line-break? (car l))
+	(if next?
+	    (loop (cdr l) #t accum title tag)
+	    (let ([m (match-newline-whitespace (cdr l))])
+              (if m
+                  (let ([part (loop m #t null title tag)])
+                    (make-part (part-tag part)
+                               (part-title-content part)
+                               (part-collected-info part)
+                               (make-flow (append (decode-accum-para accum)
+                                                  (flow-paragraphs (part-flow part))))
+                               (part-parts part)))
+                  (loop (cdr l) #f (cons (car l) accum) title tag))))]
+       [else (loop (cdr l) #f (cons (car l) accum) title tag)])))
+
+  (define (decode-part l tag title depth)
+    (decode-flow* l tag title depth))
+
+  (define (decode-flow l)
+    (part-flow (decode-flow* l #f #f #f)))
+
+  (define (match-newline-whitespace l)
+    (cond
+     [(null? l) #f]
+     [(line-break? (car l))
+      (skip-whitespace l)]
+     [(splice? (car l))
+      (match-newline-whitespace (append (splice-run (car l))
+                                        (cdr l)))]
+     [(whitespace? (car l))
+      (match-newline-whitespace (cdr l))]
+     [else #f]))
+
+  (define (skip-whitespace l)
+    (let loop ([l l])
+      (if (or (null? l)
+              (not (whitespace? (car l))))
+          l
+          (loop (cdr l)))))
+
+  (define (decode l)
+    (decode-part l #f #f 0))
+
+  (define (decode-paragraph l)
+    (make-paragraph 
+     (decode-content l)))
+
+  (define (decode-content l)
+    (apply append
+           (map (lambda (s)
+                  (cond
+                   [(string? s)
+                    (decode-string s)]
+                   [else (list s)]))
+                (skip-whitespace l)))))

collects/scribble/doclang.ss

@@ -0,0 +1,61 @@
+
+(module doclang mzscheme
+  (require "struct.ss"
+           "decode.ss"
+           (lib "kw.ss"))
+  (require-for-syntax (lib "kerncase.ss" "syntax"))
+
+  (provide (all-from-except mzscheme #%module-begin)
+           (rename *module-begin #%module-begin))
+
+  ;; Module wrapper ----------------------------------------
+
+  (define-syntax (*module-begin stx)
+    (syntax-case stx ()
+      [(_ id exprs . body)
+       #'(#%plain-module-begin
+          (doc-begin id exprs . body))]))
+
+  (define-syntax (doc-begin stx)
+    (syntax-case stx ()
+      [(_ m-id (expr ...))
+       #`(begin
+           (define m-id (decode (list . #,(reverse (syntax->list #'(expr ...))))))
+           (provide m-id))]
+      [(_ m-id exprs . body)
+       ;; `body' probably starts with lots of string constants;
+       ;; it's slow to trampoline on every string, so do them
+       ;; in a batch here:
+       (let loop ([body #'body]
+                  [accum null])
+         (syntax-case body ()
+           [(s . rest)
+            (string? (syntax-e #'s))
+            (loop #'rest (cons #'s accum))]
+           [()
+            (with-syntax ([(accum ...) accum])
+              #`(doc-begin m-id (accum ... . exprs)))]
+           [(body1 . body)
+            (with-syntax ([exprs (append accum #'exprs)])
+              (let ([expanded (local-expand #'body1
+                                            'module
+                                            (append
+                                             (kernel-form-identifier-list #'here)
+                                             (syntax->list #'(provide
+                                                              require
+                                                              require-for-syntax))))])
+                (syntax-case expanded  (begin)
+                  [(begin body1 ...)
+                   #`(doc-begin m-id exprs body1 ... . body)]
+                  [(id . rest)
+                   (and (identifier? #'id)
+                        (ormap (lambda (kw) (module-identifier=? #'id kw))
+                               (syntax->list #'(require 
+                                                provide 
+                                                require-for-syntax
+                                                define-values
+                                                define-syntaxes
+                                                define-for-syntaxes))))
+                   #`(begin #,expanded (doc-begin m-id exprs . body))]
+                  [_else
+                   #`(doc-begin m-id (#,expanded . exprs) . body)])))]))])))

collects/scribble/docreader.ss

@@ -0,0 +1,34 @@
+
+(module docreader mzscheme
+  (require (prefix scribble: "reader.ss")
+           (lib "kw.ss"))
+
+  (provide (rename *read read)
+	   (rename *read-syntax read-syntax))
+
+  (define (call-with-scribble-params t)
+    (parameterize ([scribble:read-accept-=-keyword #f]
+                   [scribble:read-insert-indents #f])
+      (t)))
+
+  (define/kw (*read #:optional [inp (current-input-port)])
+    (call-with-scribble-params
+     (lambda ()
+       (wrap inp (scribble:read-inside inp)))))
+     
+  (define/kw (*read-syntax #:optional src [port (current-input-port)])
+    (call-with-scribble-params
+     (lambda ()
+       (wrap port (scribble:read-inside-syntax src port)))))
+
+  (define (wrap port body)
+    (let* ([p-name (object-name port)]
+	   [name (if (path? p-name)
+		     (let-values ([(base name dir?) (split-path p-name)])
+		       (string->symbol (path->string (path-replace-suffix name #""))))
+		     'page)]
+           [id 'doc])
+      `(module ,name (lib "doclang.ss" "scribble")
+         (#%module-begin
+          ,id ()
+          . ,body)))))

collects/scribble/eval.ss

@@ -0,0 +1,227 @@
+
+(module eval mzscheme
+  (require "manual.ss"
+           "struct.ss"
+           "scheme.ss"
+           "decode.ss"
+           (lib "class.ss")
+           (lib "file.ss")
+           (lib "string.ss"))
+
+  (provide interaction
+           interaction-eval
+           interaction-eval-show
+           schemeblock+eval
+           schememod+eval
+           def+int
+           defs+int
+           examples
+           defexamples
+
+           current-int-namespace
+           eval-example-string
+
+           scribble-eval-handler)
+
+  (define current-int-namespace (make-parameter (make-namespace)))
+  (define scribble-eval-handler (make-parameter (lambda (c? x) (eval x))))
+
+  (define image-counter 0)
+
+  (define (interleave title expr-paras val-list+outputs)
+    (make-table
+     #f
+     (append
+      (if title (list (list title)) null)
+      (let loop ([expr-paras expr-paras]
+                 [val-list+outputs val-list+outputs]
+                 [first? #t])
+        (if (null? expr-paras)
+            null
+            (append
+             (list (list (let ([p (car expr-paras)])
+                           (if (flow? p)
+                               p
+                               (make-flow (list p))))))
+             (append
+              (if (string? (car val-list+outputs))
+                  (list 
+                   (list (make-flow (list (make-paragraph
+                                           (list
+                                            (hspace 2)
+                                            (span-class "schemeerror"
+                                                        (italic (car val-list+outputs)))))))))
+                  (append
+                   (if (string=? "" (cdar val-list+outputs))
+                       null
+                       (list
+                        (list
+                         (make-flow 
+                          (list
+                           (let ([s (regexp-split #rx"\n"
+                                                  (regexp-replace #rx"\n$"
+                                                                  (cdar val-list+outputs)
+                                                                  ""))])
+                             (if (= 1 (length s))
+                                 (make-paragraph
+                                  (list
+                                   (hspace 2)
+                                   (span-class "schemestdout" (car s))))
+                                 (make-table
+                                  #f
+                                  (map (lambda (s)
+                                         (list (make-flow (list (make-paragraph
+                                                                 (list
+                                                                  (hspace 2)
+                                                                  (span-class "schemestdout" s)))))))
+                                       s)))))))))
+                   (let ([val-list (caar val-list+outputs)])
+                     (if (equal? val-list (list (void)))
+                         null
+                         (map (lambda (v)
+                                (list (make-flow (list (make-paragraph 
+                                                        (list
+                                                         (hspace 2)
+                                                         (span-class "schemeresult"
+                                                                     (to-element/no-color v))))))))
+                              val-list)))))
+              (loop (cdr expr-paras)
+                    (cdr val-list+outputs)
+                    #f))))))))
+
+  (define (do-eval s)
+    (cond
+     [(and (list? s)
+           (eq? 'code:line (car s))
+           (= (length s) 3)
+           (list? (caddr s))
+           (eq? 'code:comment (caaddr s)))
+      (do-eval (cadr s))]
+     [(and (list? s)
+           (eq? 'eval:alts (car s))
+           (= (length s) 3))
+      (do-eval (caddr s))]
+     [else
+      (let ([o (open-output-string)])
+        (parameterize ([current-output-port o])
+          (with-handlers ([exn? (lambda (e)
+                                  (exn-message e))])
+            (cons (do-plain-eval s #t)
+                  (get-output-string o)))))]))
+
+  (define (strip-comments s)
+    (cond
+     [(and (pair? s)
+           (pair? (car s))
+           (eq? (caar s) 'code:comment))
+      (strip-comments (cdr s))]
+     [(pair? s)
+      (cons (strip-comments (car s))
+            (strip-comments (cdr s)))]
+     [(eq? s 'code:blank) (void)]
+     [else s]))
+      
+
+  (define (do-plain-eval s catching-exns?)
+    (parameterize ([current-namespace (current-int-namespace)])
+        (call-with-values (lambda () ((scribble-eval-handler) catching-exns? (strip-comments s))) list)))
+
+  (define-syntax interaction-eval
+    (syntax-rules ()
+      [(_ e) (#%expression
+              (begin (parameterize ([current-command-line-arguments #()])
+                       (do-plain-eval (quote e) #f))
+                     ""))]))
+
+
+  (define (show-val v)
+    (span-class "schemeresult"
+                (to-element/no-color v)))
+
+  (define-syntax interaction-eval-show
+    (syntax-rules ()
+      [(_ e) (#%expression
+              (parameterize ([current-command-line-arguments #()])
+                (show-val (car (do-plain-eval (quote e) #f)))))]))
+
+  (define (eval-example-string s)
+    (eval (read (open-input-string s))))
+
+  (parameterize ([current-namespace (current-int-namespace)])
+    (eval `(define eval-example-string ,eval-example-string)))
+
+  (define-syntax schemeinput*
+    (syntax-rules (eval-example-string eval:alts)
+      [(_ (eval-example-string s))
+       (make-paragraph
+        (list
+         (hspace 2)
+         (tt "> ")
+         (span-class "schemevalue" (schemefont s))))]
+      [(_ (eval:alts a b)) (schemeinput* a)]
+      [(_ e) (schemeinput e)]))
+
+  (define (defspace p)
+    (make-flow (list p
+                     (make-paragraph null))))
+
+  (define-syntax (schemedefinput* stx)
+    (syntax-case stx (eval-example-string define)
+      [(_ (eval-example-string s))
+       #'(schemeinput* (eval-example-string s))]
+      [(_ (define . rest))
+       (syntax-case stx ()
+         [(_ e) #'(defspace (schemeblock e))])]
+      [(_ (code:line (define . rest) . rest2))
+       (syntax-case stx ()
+         [(_ e) #'(defspace (schemeblock e))])]
+      [(_ e) #'(schemeinput e)]))
+
+  (define-syntax titled-interaction
+    (syntax-rules ()
+      [(_ t schemeinput* e ...)
+       (interleave t
+                   (list (schemeinput* e) ...)
+                   (map do-eval (list (quote e) ...)))]))
+
+    (define-syntax interaction
+      (syntax-rules ()
+        [(_ e ...) (titled-interaction #f schemeinput* e ...)]))
+
+  (define-syntax schemeblock+eval
+    (syntax-rules ()
+      [(_ e ...)
+       (#%expression
+        (begin (interaction-eval e) ...
+               (schemeblock e ...)))]))
+
+  (define-syntax schememod+eval
+    (syntax-rules ()
+      [(_ name e ...)
+       (#%expression
+        (begin (interaction-eval e) ...
+               (schememod name e ...)))]))
+
+  (define-syntax def+int
+    (syntax-rules ()
+      [(_ def e ...)
+       (make-splice (list (schemeblock+eval def)
+                          (interaction e ...)))]))
+
+  (define-syntax defs+int
+    (syntax-rules ()
+      [(_ [def ...] e ...)
+       (make-splice (list (schemeblock+eval def ...)
+                          (interaction e ...)))]))
+
+  (define example-title
+    (make-flow (list (make-paragraph (list "Examples:")))))
+  (define-syntax examples
+    (syntax-rules ()
+      [(_ e ...)
+       (titled-interaction example-title schemeinput* e ...)]))
+  (define-syntax defexamples
+    (syntax-rules ()
+      [(_ e ...)
+       (titled-interaction example-title schemedefinput* e ...)])))
+

collects/scribble/html-render.ss

@@ -0,0 +1,324 @@
+
+(module html-render mzscheme
+  (require "struct.ss"
+           (lib "class.ss")
+           (lib "file.ss")
+           (lib "runtime-path.ss")
+           (prefix xml: (lib "xml.ss" "xml")))
+  (provide render-mixin
+           render-multi-mixin)
+
+  (xml:empty-tag-shorthand xml:html-empty-tags)
+
+  (define-runtime-path scribble-css "scribble.css")
+
+  (define current-subdirectory (make-parameter #f))
+  (define current-output-file (make-parameter #f))
+  (define on-separate-page (make-parameter #f))
+  (define collecting-sub (make-parameter 0))
+
+  ;; ----------------------------------------
+  ;;  main mixin
+
+  (define (render-mixin %)
+    (class %
+      (inherit render-content
+               render-flow-element
+               collect-part
+               install-file
+               get-dest-directory
+               format-number)
+
+      (define/override (get-suffix) #".html")
+
+      ;; ----------------------------------------
+
+      (define/override (collect ds fns)
+        (let ([ht (make-hash-table 'equal)])
+          (map (lambda (d fn)
+                 (parameterize ([current-output-file fn])
+                   (collect-part d #f ht null)))
+               ds
+               fns)
+          ht))
+
+      (define/override (collect-part-tag d ht)
+        (hash-table-put! ht 
+                         `(part ,(part-tag d)) 
+                         (list (current-output-file)
+                               (part-title-content d))))
+
+      (define/override (collect-target-element i ht)
+        (hash-table-put! ht 
+                         (target-element-tag i)
+                         (list (current-output-file) #f)))
+
+      ;; ----------------------------------------
+
+      (define/public (render-one-part d ht fn number)
+        (parameterize ([current-output-file fn])
+          (let ([xpr `(html () 
+                            (head
+                             (meta ((http-equiv "content-type")
+                                    (content "text-html; charset=utf-8")))
+                             ,@(let ([c (part-title-content d)])
+                                 (if c
+                                     `((title ,@(render-content c d ht)))
+                                     null))
+                             (link ((rel "stylesheet")
+                                    (type "text/css")
+                                    (href "scribble.css")
+                                    (title "default"))))
+                            (body ,@(render-part d ht)))])
+            (install-file scribble-css)
+            (xml:write-xml/content (xml:xexpr->xml xpr)))))
+
+      (define/override (render-one d ht fn)
+        (render-one-part d ht fn null))
+
+      (define/override (render-part d ht)
+        (let ([number (collected-info-number (part-collected-info d))])
+          `(,@(if (and (not (part-title-content d))
+                       (null? number))
+                  null
+                  `((,(case (length number)
+                        [(0) 'h2]
+                        [(1) 'h3]
+                        [else 'h4])
+                     ,@(format-number number '((tt nbsp)))
+                     ,@(if (part-tag d)
+                           `((a ((name ,(format "~a" `(part ,(part-tag d)))))))
+                           null)
+                     ,@(if (part-title-content d)
+                           (render-content (part-title-content d) d ht)
+                           null))))
+            ,@(render-flow* (part-flow d) d ht #f)
+            ,@(let loop ([pos 1]
+                         [secs (part-parts d)])
+                (if (null? secs)
+                    null
+                    (append
+                     (render-part (car secs) ht)
+                     (loop (add1 pos) (cdr secs))))))))
+
+      (define/private (render-flow* p part ht special-last?)
+        ;; Wrap each table with <p>, except for a trailing table
+        ;;  when `special-last?' is #t
+        (let loop ([f (flow-paragraphs p)])
+          (cond
+           [(null? f) null]
+           [(and (table? (car f)) 
+                 (or (not special-last?)
+                     (not (null? (cdr f)))))
+            (cons `(p ,@(render-flow-element (car f) part ht))
+                  (loop (cdr f)))]
+           [else
+            (append (render-flow-element (car f) part ht)
+                    (loop (cdr f)))])))
+
+      (define/override (render-flow p part ht)
+        (render-flow* p part ht #t))
+
+      (define/override (render-paragraph p part ht)
+        `((p ,@(super render-paragraph p part ht))))
+
+      (define/override (render-element e part ht)
+        (cond
+         [(target-element? e)
+          `((a ((name ,(target-element-tag e))) ,@(render-plain-element e part ht)))]
+         [(link-element? e)
+          (let ([dest (hash-table-get ht (link-element-tag e) #f)])
+            (if dest
+                `((a ((href ,(format "~a#~a" 
+                                     (from-root (car dest)
+                                                (get-dest-directory))
+                                     (link-element-tag e)))
+                      ,@(if (string? (element-style e))
+                            `((class ,(element-style e)))
+                            null))
+                     ,@(if (null? (element-content e))
+                           (render-content (cadr dest) part ht)
+                           (render-content (element-content e) part ht))))
+                `((font ((class "badlink")) 
+                        ,@(if (null? (element-content e))
+                              `(,(format "~s" (link-element-tag e)))
+                              (render-plain-element e part ht))))))]
+         [else (render-plain-element e part ht)]))
+
+      (define/private (render-plain-element e part ht)
+        (let ([style (and (element? e)
+                          (element-style e))])
+          (cond
+           [(symbol? style)
+            (case style
+              [(italic) `((i ,@(super render-element e part ht)))]
+              [(bold) `((b ,@(super render-element e part ht)))]
+              [(tt) `((tt ,@(super render-element e part ht)))]
+              [(sf) `((b (font ([size "-1"][face "Helvetica"]) ,@(super render-element e part ht))))]
+              [(subscript) `((sub ,@(super render-element e part ht)))]
+              [(superscript) `((sup ,@(super render-element e part ht)))]
+              [(hspace) `((tt ,@(map (lambda (c) 'nbsp) (string->list (content->string (element-content e))))))]
+              [else (error 'html-render "unrecognized style symbol: ~e" style)])]
+           [(string? style) 
+            `((span ([class ,style]) ,@(super render-element e part ht)))]
+           [(target-url? style)
+            `((a ((href ,(target-url-addr style))) ,@(super render-element e part ht)))]
+           [(image-file? style) `((img ((src ,(install-file (image-file-path style))))))]
+           [else (super render-element e part ht)])))
+
+      (define/override (render-table t part ht)
+        `((table ((cellspacing "0") ,@(case (table-style t)
+                                        [(boxed) '((width "100%") (bgcolor "lightgray"))]
+                                        [(centered) '((align "center"))]
+                                        [else null]))
+                 ,@(map (lambda (flows)
+                          `(tr ,@(map (lambda (d a)
+                                        `(td ,@(case a
+                                                 [(#f) null]
+                                                 [(right) '(((align "right")))]
+                                                 [(left) '(((align "left")))])
+                                             ,@(render-flow d part ht)))
+                                      flows
+                                      (cdr (or (and (list? (table-style t))
+                                                    (assoc 'alignment (or (table-style t) null)))
+                                               (cons #f (map (lambda (x) #f) flows)))))))
+                        (table-flowss t)))))
+
+      (define/override (render-itemization t part ht)
+        `((ul
+           ,@(map (lambda (flow)
+                    `(li ,@(render-flow flow part ht)))
+                  (itemization-flows t)))))
+
+      (define/override (render-other i part ht)
+        (list (cond
+               [(string? i) i]
+               [(eq? i 'mdash) `(span " " ndash " ")]
+               [(symbol? i) i]
+               [else (format "~s" i)])))
+      
+      ;; ----------------------------------------
+
+      (super-new)))
+
+  ;; ----------------------------------------
+  ;; multi-file output 
+
+  (define (render-multi-mixin %)
+    (class %
+      (inherit render-one
+               render-one-part
+               render-content)
+
+      (define/override (get-suffix) #"")
+
+      (define/override (get-dest-directory)
+        (or (build-path (or (super get-dest-directory) (current-directory))
+                        (current-subdirectory))
+            (super get-dest-directory)))
+
+      (define/private (derive-filename d)
+        (format "~a.html" (regexp-replace*
+                           "[^-a-zA-Z0-9_=]"
+                           (or (format "~a" (part-tag d))
+                               (content->string (part-title-content d)))
+                           "_")))
+
+      (define/override (collect ds fns)
+        (super collect ds (map (lambda (fn)
+                                 (build-path fn "index.html"))
+                               fns)))
+
+      (define/override (collect-part d parent ht number)
+        (let ([prev-sub (collecting-sub)])
+          (parameterize ([collecting-sub (add1 prev-sub)])
+            (if (= 1 prev-sub)
+                (let ([filename (derive-filename d)])
+                  (parameterize ([current-output-file (build-path (path-only (current-output-file))
+                                                                  filename)])
+                    (super collect-part d parent ht number)))
+                (super collect-part d parent ht number)))))
+      
+      (define/override (render ds fns ht)
+        (map (lambda (d fn)
+               (printf " [Output to ~a/index.html]\n" fn)
+               (unless (directory-exists? fn)
+                 (make-directory fn))
+               (parameterize ([current-subdirectory (file-name-from-path fn)])
+                 (let ([fn (build-path fn "index.html")])
+                   (with-output-to-file fn
+                     (lambda ()
+                       (render-one d ht fn))
+                     'truncate/replace))))
+             ds
+             fns))
+
+      (define/override (render-part d ht)
+        (let ([number (collected-info-number (part-collected-info d))])
+          (cond
+           [(and (not (on-separate-page))
+                 (= 1 (length number)))
+            ;; Render as just a link, and put the actual 
+            ;; content in a new file:
+            (let* ([filename (derive-filename d)]
+                   [full-path (build-path (path-only (current-output-file))
+                                          filename)])
+              (parameterize ([on-separate-page #t])
+                (with-output-to-file full-path
+                  (lambda ()
+                    (render-one-part d ht full-path number))
+                  'truncate/replace)
+                null
+                #;
+                `((table 
+                   ((width "90%") (cellspacing "0") (align "center"))
+                   ,@(render-toc-entry d filename ht number)))))]
+           [else
+            ;; Normal section render
+            (super render-part d ht)])))
+
+      (super-new)))
+
+  ;; ----------------------------------------
+  ;; utils
+
+  (define (from-root p d)
+    (if d
+        (let ([e-d (explode (path->complete-path d (current-directory)))]
+              [e-p (explode (path->complete-path p (current-directory)))])
+          (let loop ([e-d e-d]
+                     [e-p e-p])
+            (cond
+             [(null? e-d) (let loop ([e-p e-p])
+                            (cond
+                             [(null? e-p) "/"]
+                             [(null? (cdr e-p)) (car e-p)]
+                             [(eq? 'same (car e-p)) (loop (cdr e-p))]
+                             [(eq? 'up (car e-p)) 
+                              (string-append "../" (loop (cdr e-p)))]
+                             [else (string-append (car e-p)
+                                                  "/"
+                                                  (loop (cdr e-p)))]))]
+             [(equal? (car e-d) (car e-p))
+              (loop (cdr e-d) (cdr e-p))]
+             [(eq? 'same (car e-d))
+              (loop (cdr e-d) e-p)]
+             [(eq? 'same (car e-p))
+              (loop e-d (cdr e-p))]
+             [else
+              (string-append
+               (apply string-append (map (lambda (x) "../") e-d))
+               (loop null e-p))])))
+        p))
+
+  (define (explode p)
+    (reverse (let loop ([p p])
+               (let-values ([(base name dir?) (split-path p)])
+                 (let ([name (if base
+                                 (if (path? name)
+                                     (path-element->string name)
+                                     name)
+                                 name)])
+                   (if (path? base)
+                       (cons name (loop base))
+                       (list name))))))))

collects/scribble/latex-render.ss

@@ -0,0 +1,208 @@
+
+(module latex-render mzscheme
+  (require "struct.ss"
+           (lib "class.ss"))
+  (provide render-mixin)
+
+  (define current-table-depth (make-parameter 0))
+
+  (define-struct (toc-paragraph paragraph) ())
+
+  (define (render-mixin %)
+    (class %
+      (define/override (get-suffix) #".tex")
+
+      (inherit render-flow
+               render-content
+               install-file)
+
+      (define (define-color s s2)
+        (printf "\\newcommand{\\~a}[1]{{\\texttt{\\color{~a}{#1}}}}\n" s s2))
+
+      (define/override (render-one d ht fn)
+        (printf "\\documentclass{article}\n")
+        (printf "\\parskip=10pt%\n")
+        (printf "\\parindent=0pt%\n")
+        (printf "\\usepackage{graphicx}\n")
+        (printf "\\usepackage{fullpage}\n")
+        (printf "\\usepackage{longtable}\n")
+        (printf "\\usepackage[usenames,dvipsnames]{color}\n")
+        (define-color "schemeplain" "black")
+        (printf "\\newcommand{\\schemekeyword}[1]{{\\color{black}{\\texttt{\\textbf{#1}}}}}\n")
+        (printf "\\newcommand{\\schemesyntaxlink}[1]{\\schemekeyword{#1}}\n")
+        (define-color "schemecomment" "Brown")
+        (define-color "schemeparen" "BrickRed")
+        (define-color "schemeinputcol" "BrickRed")
+        (define-color "schemesymbol" "NavyBlue")
+        (define-color "schemevalue" "ForestGreen")
+        (define-color "schemevaluelink" "blue")
+        (define-color "schemeresult" "blue")
+        (define-color "schemestdout" "Purple")
+        (define-color "schemevariablecol" "NavyBlue")
+        (printf "\\newcommand{\\schemevariable}[1]{{\\schemevariablecol{\\textsl{#1}}}}\n")
+        (define-color "schemeerrorcol" "red")
+        (printf "\\newcommand{\\schemeerror}[1]{{\\schemeerrorcol{\\textit{#1}}}}\n")
+        (printf "\\newcommand{\\schemeopt}[1]{#1}\n")
+        (printf "\\newcommand{\\textsub}[1]{$_{#1}$}\n")
+        (printf "\\newcommand{\\textsuper}[1]{$^{#1}$}\n")
+        (printf "\\definecolor{LightGray}{rgb}{0.85,0.85,0.85}\n")
+        (printf "\\newcommand{\\schemeinput}[1]{\\colorbox{LightGray}{\\schemeinputcol{#1}}}\n")
+        (printf "\\begin{document}\n")
+        (when (part-title-content d)
+          (printf "\\title{")
+          (render-content (part-title-content d) d ht)
+          (printf "}\\maketitle\n"))
+        (render-part d ht)
+        (printf "\\end{document}\n"))
+
+      (define/override (render-part d ht)
+        (let ([number (collected-info-number (part-collected-info d))])
+          (when (and (part-title-content d)
+                     (pair? number))
+            (printf "\\~a~a{"
+                    (case (length number)
+                      [(0 1) "section"]
+                      [(2) "subsection"]
+                      [(3) "subsubsection"]
+                      [else "subsubsection*"])
+                    (if (and (pair? number)
+                             (not (car number)))
+                        "*"
+                        ""))
+            (render-content (part-title-content d) d ht)
+            (printf "}"))
+          (when (part-tag d)
+            (printf "\\label{section:~a}" (part-tag d)))
+          (render-flow (part-flow d) d ht)
+          (for-each (lambda (sec) (render-part sec ht))
+                    (part-parts d))
+          null))
+      
+      (define/override (render-paragraph p part ht)
+        (printf "\n\n")
+        (if (toc-paragraph? p)
+            (printf "\\tableofcontents")
+            (super render-paragraph p part ht))
+        (printf "\n\n")
+        null)
+
+      (define/override (render-element e part ht)
+        (when (and (link-element? e)
+                   (pair? (link-element-tag e))
+                   (eq? 'part (car (link-element-tag e))))
+          (printf "\\S\\ref{section:~a} " (cadr (link-element-tag e))))
+        (let ([style (and (element? e)
+                          (element-style e))]
+              [wrap (lambda (e s)
+                      (printf "{\\~a{" s)
+                      (super render-element e part ht)
+                      (printf "}}"))])
+          (cond
+           [(symbol? style)
+            (case style
+              [(italic) (wrap e "textit")]
+              [(bold) (wrap e "textbf")]
+              [(tt) (wrap e "texttt")]
+              [(sf) (wrap e "textsf")]
+              [(subscript) (wrap e "textsub")]
+              [(superscript) (wrap e "textsuper")]
+              [(hspace) (let ([s (content->string (element-content e))])
+                          (unless (zero? (string-length s))
+                            (printf "{\\texttt ~a}"
+                                    (regexp-replace* #rx"." s "~"))))]
+              [else (error 'latex-render "unrecognzied style symbol: ~s" style)])]
+           [(string? style)
+            (wrap e style)]
+           [(image-file? style) 
+            (let ([fn (install-file (image-file-path style))])
+              (printf "\\includegraphics{~a}" fn))]
+           [else (super render-element e part ht)]))
+        null)
+
+      (define/override (render-table t part ht)
+        (let* ([boxed? (eq? 'boxed (table-style t))]
+               [index? (eq? 'index (table-style t))]
+               [tableform (cond
+                           [index? "theindex"]
+                           [(zero? (current-table-depth))
+                            "longtable"]
+                           [else "tabular"])]
+               [opt (if (zero? (current-table-depth))
+                        "[l]"
+                        "")])
+          (unless (null? (table-flowss t))
+            (parameterize ([current-table-depth (add1 (current-table-depth))])
+              (if index?
+                  (printf "\n\n\\begin{theindex}\n")
+                  (printf "\n\n~a\\begin{~a}~a{@{}~a@{}}\n"
+                          (if boxed? "\\vspace{4ex}\\hrule\n\\vspace{-2ex}\n" "")
+                          tableform
+                          opt
+                          (make-string (length (car (table-flowss t))) #\l)))
+              (for-each (lambda (flows)
+                          (let loop ([flows flows])
+                            (unless (null? flows)
+                              (render-flow (car flows) part ht)
+                              (unless (null? (cdr flows))
+                                (printf " &\n")
+                                (loop (cdr flows)))))
+                          (unless index?
+                            (printf " \\\\\n")))
+                        (table-flowss t))
+              (printf "\n\n\\end{~a}\n" tableform))))
+        null)
+
+      (define/override (render-itemization t part ht)
+        (printf "\n\n\\begin{itemize}\n")
+        (for-each (lambda (flow)
+                    (printf "\n\n\\item ")
+                    (render-flow flow part ht))
+                  (itemization-flows t))
+        (printf "\n\n\\end{itemize}\n")
+        null)
+
+      (define/override (render-other i part ht)
+        (cond
+         [(string? i) (display-protected i)]
+         [(symbol? i) (display
+                       (case i
+                         [(nbsp) "~"]
+                         [(mdash) "---"]
+                         [(ndash) "--"]
+                         [(ldquo) "``"]
+                         [(rdquo) "''"]
+                         [(rsquo) "'"]
+                         [(rarr) "$\\rightarrow$"]))]
+         [else (display-protected (format "~s" i))])
+        null)
+
+      (define/private (display-protected s)
+        (let ([len (string-length s)])
+          (let loop ([i 0])
+            (unless (= i len)
+              (let ([c (string-ref s i)])
+                (case c
+                  [(#\\) (display "$\\backslash$")]
+                  [(#\_) (display "$\\_$")]
+                  [(#\>) (display "$>$")]
+                  [(#\<) (display "$<$")]
+                  [(#\~) (display "$\\sim$")]
+                  [(#\{ #\} #\# #\% #\&) (display "\\") (display c)]
+                  [(#\uDF) (display "{\\ss}")]
+                  [(#\u039A #\u0391 #\u039F #\u03A3
+                    #\u03BA #\u03b1 #\u03BF #\u03C3)
+                   (printf "$\\backslash$u~a"
+                           (let ([s (format "0000~x" (char->integer c))])
+                             (substring s (- (string-length s) 4))))]
+                  [else (display c)]))
+              (loop (add1 i))))))
+                  
+      ;; ----------------------------------------
+
+      (define/override (table-of-contents sec ht)
+        ;; FIXME: isn't local to the section
+        (make-toc-paragraph null))
+
+      ;; ----------------------------------------
+
+      (super-new))))

collects/scribble/manual.ss

@@ -0,0 +1,467 @@
+
+(module manual mzscheme
+  (require "decode.ss"
+           "struct.ss"
+           "scheme.ss"
+           "config.ss"
+           "basic.ss"
+           (lib "string.ss")
+           (lib "kw.ss")
+           (lib "list.ss")
+           (lib "class.ss"))
+
+  (provide (all-from "basic.ss"))
+
+  (provide PLaneT)
+  (define PLaneT "PLaneT")
+
+  (define-code schemeblock0 to-paragraph)
+  (define-code schemeblock (to-paragraph/prefix (hspace 2) 
+                                                (hspace 2)))
+  (define-code SCHEMEBLOCK (to-paragraph/prefix (hspace 2) 
+                                                (hspace 2))
+    UNSYNTAX)
+  (define-code SCHEMEBLOCK0 to-paragraph UNSYNTAX)
+  (define-code schemeinput (to-paragraph/prefix (make-element
+                                                 #f
+                                                 (list
+                                                  (hspace 2)
+                                                  (make-element 'tt (list "> " ))))
+                                                (hspace 4)))
+
+  (define-syntax (schememod stx)
+    (syntax-case stx ()
+      [(_ lang rest ...)
+       (with-syntax ([modtag (datum->syntax-object
+                              #'here
+                              '(unsyntax (schemefont "#module "))
+                              #'lang)])
+         #'(schemeblock modtag lang rest ...))]))
+
+  (define (to-element/result s)
+    (make-element "schemeresult" (list (to-element/no-color s))))
+  (define (to-element/id s)
+    (make-element "schemesymbol" (list (to-element/no-color s))))
+
+  (define-code scheme to-element unsyntax (lambda (ctx s v) s))
+  (define-code schemeresult to-element/result unsyntax (lambda (ctx s v) s))
+  (define-code schemeid to-element/id unsyntax (lambda (ctx s v) s))
+  (define-code schememodname to-element unsyntax (lambda (ctx s v) s))
+
+  (define (litchar . strs)
+    (unless (andmap string? strs)
+      (raise-type-error 'litchar "strings" strs))
+    (let ([s (apply string-append
+                    (map (lambda (s) (if (string=? s "\n") " " s))
+                         strs))])
+      (let ([spaces (regexp-match-positions #rx"^ *" s)])
+        (make-element "schemeinput" 
+                      (list (hspace (cdar spaces))
+                            (make-element 'tt (list (substring s (cdar spaces)))))))))
+
+  (define (verbatim s)
+    (let ([strs (regexp-split #rx"\n" s)])
+      (make-table
+       #f
+       (map (lambda (s)
+              (list (make-flow (list (make-paragraph 
+                                      (let ([spaces (cdar (regexp-match-positions #rx"^ *" s))])
+                                        (list 
+                                         (hspace spaces)
+                                         (make-element 'tt (list (substring s spaces))))))))))
+            strs))))
+
+  (provide schemeblock SCHEMEBLOCK
+           schemeblock0 SCHEMEBLOCK0
+           schemeinput
+           schememod
+           scheme schemeresult schemeid schememodname
+           litchar
+           verbatim)
+
+  (provide onscreen menuitem defterm
+           schemefont schemevalfont schemeresultfont schemeidfont 
+           schemeparenfont schemekeywordfont
+           file exec
+           link procedure
+           idefterm)
+
+  (define/kw (onscreen #:body str)
+    (make-element 'sf (decode-content str)))
+  (define (menuitem menu item)
+    (make-element 'sf (list menu "|" item)))
+  (define/kw (defterm #:body str)
+    (make-element 'italic (decode-content str)))
+  (define/kw (idefterm #:body str)
+    (let ([c (decode-content str)])
+      (make-element 'italic c)))
+  (define/kw (schemefont #:body str)
+    (apply tt str))
+  (define/kw (schemevalfont #:body str)
+    (make-element "schemevalue" (decode-content str)))
+  (define/kw (schemeresultfont #:body str)
+    (make-element "schemeresult" (decode-content str)))
+  (define/kw (schemeidfont #:body str)
+    (make-element "schemesymbol" (decode-content str)))
+  (define/kw (schemeparenfont #:body str)
+    (make-element "schemeparen" (decode-content str)))
+  (define/kw (schemekeywordfont #:body str)
+    (make-element "schemekeyword" (decode-content str)))
+  (define/kw (file #:body str)
+    (make-element 'tt (append (list "\"") (decode-content str) (list "\""))))
+  (define/kw (exec #:body str)
+    (make-element 'tt (decode-content str)))
+  (define/kw (procedure #:body str)
+    (make-element 'tt (append (list "#<procedure:") (decode-content str) (list ">"))))
+
+  (define/kw (link url #:body str)
+    (make-element (make-target-url url) (decode-content str)))
+
+  (provide t)
+  (define/kw (t #:body str)
+    (decode-paragraph str))
+
+  (provide schememodule)
+  (define-syntax (schememodule stx)
+    (syntax-rules ()
+      [(_ body ...)
+       (code body ...)]))
+
+  ;; ----------------------------------------
+
+  (provide defproc defproc* defstruct defthing defform 
+           specsubform specsubform/inline
+           var svar void-const)
+
+  (define (void-const)
+    "void")
+
+  (define dots0
+    (make-element #f (list "...")))
+  (define dots1
+    (make-element #f (list "..."  (superscript "+"))))
+
+  (define-syntax defproc 
+    (syntax-rules ()
+      [(_ s-exp result desc ...)
+       (*defproc '[s-exp] '[result] (lambda () (list desc ...)))]))
+  (define-syntax defproc* 
+    (syntax-rules ()
+      [(_ [[s-exp result] ...] desc ...)
+       (*defproc '[s-exp ...] '[result ...] (lambda () (list desc ...)))]))
+  (define-syntax defstruct
+    (syntax-rules ()
+      [(_ name fields desc ...)
+       (*defstruct 'name 'fields (lambda () (list desc ...)))]))
+  (define-syntax (defform stx)
+    (syntax-case stx ()
+      [(_ spec desc ...)
+       (with-syntax ([new-spec
+                      (syntax-case #'spec ()
+                        [(name . rest)
+                         (datum->syntax-object #'spec
+                                               (cons
+                                                (datum->syntax-object #'here
+                                                                      '(unsyntax x)
+                                                                      #'name)
+                                                #'rest)
+                                               #'spec)])])
+         #'(*defform 'spec (lambda (x) (schemeblock0 new-spec)) (lambda () (list desc ...))))]))
+  (define-syntax specsubform
+    (syntax-rules ()
+      [(_ spec desc ...)
+       (*specsubform 'spec (lambda () (schemeblock0 spec)) (lambda () (list desc ...)))]))
+  (define-syntax specsubform/inline
+    (syntax-rules ()
+      [(_ spec desc ...)
+       (*specsubform 'spec #f (lambda () (list desc ...)))]))
+  (define-syntax defthing
+    (syntax-rules ()
+      [(_ id result desc ...)
+       (*defthing 'id 'result (lambda () (list desc ...)))]))
+  (define-syntax var
+    (syntax-rules ()
+      [(_ id) (*var 'id)]))
+  (define-syntax svar
+    (syntax-rules ()
+      [(_ id) (*var 'id)]))
+
+  (define (*defproc prototypes results content-thunk)
+    (let ([spacer (hspace 1)]
+          [has-optional? (lambda (arg)
+                           (and (pair? arg)
+                                ((length arg) . > . (if (keyword? (car arg))
+                                                        2
+                                                        3))))]
+          [arg->elem (lambda (v)
+                       (cond
+                        [(pair? v)
+                         (if (keyword? (car v))
+                             (make-element #f (list (to-element (car v))
+                                                    (hspace 1)
+                                                    (to-element (cadr v))))
+                             (to-element (car v)))]
+                        [(eq? v '...1)
+                         dots1]
+                        [(eq? v '...0)
+                         dots0]
+                        [else v]))])
+      (parameterize ([current-variable-list
+                      (map (lambda (i)
+                             (and (pair? i)
+                                  (car i)))
+                           (apply append (map cdr prototypes)))])        
+        (make-splice
+         (cons
+          (make-table
+           'boxed
+           (apply 
+            append
+            (map 
+             (lambda (prototype result first?)
+               (append
+                (list
+                 (list (make-flow
+                        (list
+                         (make-paragraph
+                          (list
+                           (let-values ([(required optional more-required)
+                                         (let loop ([a (cdr prototype)][r-accum null])
+                                           (if (or (null? a)
+                                                   (and (has-optional? (car a))))
+                                               (let ([req (reverse r-accum)])
+                                                 (let loop ([a a][o-accum null])
+                                                   (if (or (null? a)
+                                                           (not (has-optional? (car a))))
+                                                       (values req (reverse o-accum) a)
+                                                       (loop (cdr a) (cons (car a) o-accum)))))
+                                               (loop (cdr a) (cons (car a) r-accum))))])
+                             (to-element (append
+                                          (list (if first?
+                                                    (make-target-element
+                                                     #f
+                                                     (list (to-element (car prototype)))
+                                                     (register-scheme-definition (car prototype)))
+                                                    (to-element (car prototype))))
+                                          (map arg->elem required)
+                                          (if (null? optional)
+                                              null
+                                              (list
+                                               (to-element
+                                                (syntax-property
+                                                 (syntax-ize (map arg->elem optional) 0)
+                                                 'paren-shape
+                                                 #\?))))
+                                          (map arg->elem more-required))))
+                           (hspace 2)
+                           'rarr
+                           (hspace 2)
+                           (to-element result)))))))
+                (apply append
+                       (map (lambda (v)
+                              (cond
+                               [(pair? v)
+                                (list
+                                 (list
+                                  (make-flow
+                                   (list
+                                    (let ([v (if (keyword? (car v)) 
+                                                 (cdr v)
+                                                 v)])
+                                      (make-paragraph (append
+                                                       (list
+                                                        (hspace 2)
+                                                        (arg->elem v))
+                                                       (list
+                                                        spacer
+                                                        ":"
+                                                        spacer
+                                                        (to-element (cadr v)))
+                                                       (if (has-optional? v)
+                                                           (list spacer
+                                                                 "="
+                                                                 spacer
+                                                                 (to-element (caddr v)))
+                                                           null))))))))]
+                               [else null]))
+                            (cdr prototype)))))
+             prototypes
+             results
+             (cons #t (map (lambda (x) #f) (cdr prototypes))))))
+          (content-thunk))))))
+
+  (define (make-target-element* content wrappers)
+    (if (null? wrappers)
+        content
+        (make-target-element*
+         (make-target-element
+          #f
+          (list content)
+          (register-scheme-definition (string->symbol
+                                       (apply string-append
+                                              (map symbol->string (car wrappers))))))
+         (cdr wrappers))))
+
+  (define (*defstruct name fields content-thunk)
+    (define spacer (hspace 1))
+    (make-splice
+     (cons
+      (make-table
+       'boxed
+       (cons
+        (list (make-flow 
+               (list
+                (make-paragraph
+                 (list
+                  (to-element
+                   `(struct ,(make-target-element*
+                              (to-element name)
+                              (let ([name (if (pair? name)
+                                              (car name)
+                                              name)])
+                                (list* (list name)
+                                       (list name '?)
+                                       (list 'make- name)
+                                       (append
+                                        (map (lambda (f)
+                                               (list name '- (car f)))
+                                             fields)
+                                        (map (lambda (f)
+                                               (list 'set- name '- (car f) '!))
+                                             fields)))))
+                            ,(map car fields))))))))
+        (map (lambda (v)
+               (cond
+                [(pair? v)
+                 (list
+                  (make-flow
+                   (list
+                    (make-paragraph (append
+                                     (list
+                                      (hspace 2)
+                                      (to-element (car v)))
+                                     (list
+                                      spacer
+                                      ":"
+                                      spacer
+                                      (to-element (cadr v))))))))]
+                [else null]))
+             fields)))
+      (content-thunk))))
+
+  (define (*defthing name result-contract content-thunk)
+    (define spacer (hspace 1))
+    (make-splice
+     (cons
+      (make-table
+       'boxed
+       (list
+        (list (make-flow 
+               (list
+                (make-paragraph
+                 (list (make-target-element
+                        #f
+                        (list (to-element name))
+                        (register-scheme-definition name))
+                       spacer ":" spacer
+                       (to-element result-contract))))))))
+      (content-thunk))))
+
+  (define (*defform form form-proc content-thunk)
+    (parameterize ([current-variable-list
+                    (let loop ([form (cdr form)])
+                      (cond
+                       [(symbol? form) (list form)]
+                       [(pair? form) (append (loop (car form))
+                                             (loop (cdr form)))]
+                       [else null]))])
+      (make-splice
+       (cons
+        (make-table
+         'boxed
+         (list
+          (list (make-flow 
+                 (list
+                  ((or form-proc
+                       (lambda (x)
+                         (make-paragraph
+                          (list
+                           (to-element
+                            `(,x
+                              . ,(cdr form)))))))
+                   (make-target-element
+                    #f
+                    (list (to-element (car form)))
+                    (register-scheme-form-definition (car form)))))))))
+        (content-thunk)))))
+
+  (define (*specsubform form form-thunk content-thunk)
+    (parameterize ([current-variable-list
+                    (let loop ([form form])
+                      (cond
+                       [(symbol? form) (list form)]
+                       [(pair? form) (append (loop (car form))
+                                             (loop (cdr form)))]
+                       [else null]))])
+      (make-splice
+       (cons
+        (if form-thunk
+            (form-thunk)
+            (to-element form))
+        (content-thunk)))))
+
+  (define (*var id)
+    (to-element (*var-sym id)))
+
+  (define (*var-sym id)
+    (string->symbol (format "_~a" id)))
+
+  ;; ----------------------------------------
+
+  (provide centerline)
+  (define/kw (centerline #:body s)
+    (make-table 'centered (list (list (make-flow (list (decode-paragraph s)))))))
+
+  (provide commandline)
+  (define/kw (commandline #:body s)
+    (make-paragraph (list (hspace 2) (apply tt s))))
+           
+
+  (define (secref s)
+    (make-link-element #f null `(part ,s)))
+  (define/kw (seclink tag #:body s)
+    (make-link-element #f (decode-content s) `(part ,tag)))
+  (define/kw (*schemelink id #:body s)
+    (make-link-element #f (decode-content s) (register-scheme-definition id)))
+  (define-syntax schemelink
+    (syntax-rules ()
+      [(_ id . content) (*schemelink 'id . content)]))
+  (provide secref seclink schemelink)
+
+  (define/kw (pidefterm #:body s)
+    (let ([c (apply defterm s)])
+      (index (string-append (content->string (element-content c)) "s") 
+             c)))
+  (provide pidefterm)
+  
+  ;; ----------------------------------------
+
+  (provide math)
+  (define/kw (math #:body s)
+    (let ([c (decode-content s)])
+      (make-element #f (apply append
+                              (map (lambda (i)
+                                     (let loop ([i i])
+                                       (cond
+                                        [(string? i)
+                                         (let ([m (regexp-match #rx"^(.*)([()])(.*)$" i)])
+                                           (if m
+                                               (append (loop (cadr m))
+                                                       (list (caddr m))
+                                                       (loop (cadddr m)))
+                                               (list (make-element 'italic (list i)))))]
+                                        [else (list i)])))
+                                   c)))))
+
+  ;; ----------------------------------------
+  )

collects/scribble/run.ss

@@ -0,0 +1,89 @@
+
+(module run mzscheme
+  (require "struct.ss"
+           "base-render.ss"
+           (lib "cmdline.ss")
+           (lib "class.ss")
+           (lib "file.ss")
+           (prefix text: "text-render.ss")
+           (prefix html: "html-render.ss")
+           (prefix latex: "latex-render.ss"))
+
+  (provide (all-defined)
+           html:render-mixin
+           latex:render-mixin
+           text:render-mixin)
+
+  (define multi-html:render-mixin
+    (lambda (%)
+      (html:render-multi-mixin
+       (html:render-mixin %))))
+
+  (define current-render-mixin 
+    (make-parameter text:render-mixin))
+  (define current-dest-directory
+    (make-parameter #f))
+  (define current-dest-name
+    (make-parameter #f))
+  (define current-info-output-file
+    (make-parameter #f))
+  (define current-info-input-files
+    (make-parameter null))
+
+  (define (get-command-line-files argv)
+    (command-line
+     "scribble"
+     argv
+     [once-any
+      [("--text") "generate text-format output (the default)"
+       (void)]
+      [("--html") "generate HTML-format output file"
+       (current-render-mixin html:render-mixin)]
+      [("--htmls") "generate HTML-format output directory"
+       (current-render-mixin multi-html:render-mixin)]
+      [("--latex") "generate LaTeX-format output"
+       (current-render-mixin latex:render-mixin)]]
+     [once-each
+      [("--dest") dir "write output in <dir>"
+       (current-dest-directory dir)]
+      [("--dest-name") name "write output as <name>"
+       (current-dest-name name)]
+      [("--info-out") file "write format-specific link information to <file>"
+       (current-info-output-file file)]]
+     [multi
+      [("++info-in") file "load format-specific link information form <file>"
+       (current-info-input-files
+        (cons file (current-info-input-files)))]]
+     [args file file]))
+
+  (define (build-docs-files files)
+    (build-docs (map (lambda (file)
+                       (dynamic-require file 'doc))
+                     files)
+                files))
+    
+  (define (build-docs docs files)
+    (let ([dir (current-dest-directory)])
+      (when dir 
+        (make-directory* dir))
+
+      (let ([renderer (new ((current-render-mixin) render% )
+                           [dest-dir dir])])
+        (let* ([fns (map (lambda (fn)
+                           (let-values ([(base name dir?) (split-path fn)])
+                             (let ([fn (path-replace-suffix (or (current-dest-name) name)
+                                                            (send renderer get-suffix))])
+                               (if dir
+                                   (build-path dir fn)
+                                   fn))))
+                         files)]
+               [info (send renderer collect docs fns)])
+          (let ([info (let loop ([info info]
+                                 [files (reverse (current-info-input-files))])
+                        (if (null? files)
+                            info
+                            (loop (send renderer load-info (car files) info)
+                                  (cdr files))))])
+            (send renderer render docs fns info))
+          (when (current-info-output-file)
+            (send renderer save-info (current-info-output-file) info)))))))

collects/scribble/scheme.ss

@@ -0,0 +1,386 @@
+(module scheme mzscheme
+  (require "struct.ss"
+           "basic.ss"
+           (lib "class.ss"))
+
+  (provide define-code
+           to-element
+           to-element/no-color
+           to-paragraph
+           to-paragraph/prefix
+           register-scheme-definition
+           register-scheme-form-definition
+           syntax-ize
+           syntax-ize-hook
+           current-keyword-list
+           current-variable-list)
+
+  (define no-color "schemeplain")
+  (define meta-color "schemeplain")
+  (define keyword-color "schemekeyword")
+  (define comment-color "schemecomment")
+  (define paren-color "schemeparen")
+  (define value-color "schemevalue")
+  (define symbol-color "schemesymbol")
+  (define variable-color "schemevariable")
+  (define opt-color "schemeopt")
+
+  (define current-keyword-list 
+    (make-parameter '(define let let* letrec require provide
+                       lambda new send if cond begin else and or
+                       define-syntax syntax-rules define-struct
+                       quote quasiquote unquote unquote-splicing
+                       syntax quasisyntax unsyntax unsyntax-splicing
+                       fold-for list-for list-for* for)))
+  (define current-variable-list 
+    (make-parameter null))
+
+  (define defined-names (make-hash-table))
+
+  (define (typeset c multi-line? prefix1 prefix color?)
+    (let* ([c (syntax-ize c 0)]
+           [content null]
+           [docs null]
+           [first (syntax-case c (code:line)
+                    [(code:line e . rest) #'e]
+                    [else c])]
+           [init-col (or (syntax-column first) 0)]
+           [src-col init-col]
+           [dest-col 0]
+           [col-map (make-hash-table 'equal)]
+           [line (or (syntax-line first) 0)])
+      (define (finish-line!)
+        (when multi-line?
+          (set! docs (cons (make-flow (list (make-paragraph (reverse content))))
+                           docs))
+          (set! content null)))
+      (define (out v cls)
+        (unless (equal? v "")
+          (if (equal? v "\n")
+              (if multi-line?
+                  (begin
+                    (finish-line!)
+                    (out prefix cls))
+                  (out " " cls))
+              (begin
+                (set! content (cons (if color?
+                                        (make-element cls (list v))
+                                        (make-element 'tt (list v)))
+                                    content))
+                (set! dest-col (+ dest-col (if (string? v) (string-length v) 1)))))))
+      (define (advance c init-line!)
+        (let ([c (syntax-column c)]
+              [l (syntax-line c)]
+              [span (syntax-span c)])
+          (when (and l (l . > . line))
+            (out "\n" no-color)
+            (set! line l)
+            (init-line!))
+          (when c
+            (let ([d-col (hash-table-get col-map src-col src-col)])
+              (let ([amt (+ (- c src-col) (- d-col dest-col))])
+                (when (positive? amt)
+                  (let ([old-dest-col dest-col])
+                    (out (make-element 'hspace (list (make-string amt #\space))) no-color)
+                    (set! dest-col (+ old-dest-col amt))))))
+            (set! src-col (+ c (or span 1))))))
+      (define (convert-infix c quote-depth)
+        (let ([l (syntax->list c)])
+          (and l
+               ((length l) . >= . 3)
+               ((or (syntax-position (car l)) -inf.0)
+                . > .
+                (or (syntax-position (cadr l)) +inf.0))
+               (let ([a (car l)])
+                 (let loop ([l (cdr l)]
+                            [prev null])
+                   (cond
+                    [(null? l) #f] ; couldn't unwind
+                    [else (let ([p2 (syntax-position (car l))])
+                            (if (and p2
+                                     (p2 . > . (syntax-position a)))
+                                (datum->syntax-object c
+                                                      (append 
+                                                       (reverse prev)
+                                                       (list
+                                                        (datum->syntax-object 
+                                                         a
+                                                         (let ([val? (positive? quote-depth)])
+                                                           (make-element 
+                                                            (if val? value-color #f)
+                                                            (list
+                                                             (make-element (if val? value-color paren-color) '(". "))
+                                                             (typeset a #f "" "" (not val?))
+                                                             (make-element (if val? value-color paren-color) '(" .")))))
+                                                         (list (syntax-source a)
+                                                               (syntax-line a)
+                                                               (- (syntax-column a) 2)
+                                                               (- (syntax-position a) 2)
+                                                               (+ (syntax-span a) 4))
+                                                         a))
+                                                       l)
+                                                      c
+                                                      c)
+                                (loop (cdr l)
+                                      (cons (car l) prev))))]))))))
+      (define (loop init-line! quote-depth)
+        (lambda (c)
+          (cond
+           [(eq? 'code:blank (syntax-e c))
+            (advance c init-line!)]
+           [(and (pair? (syntax-e c))
+                 (eq? (syntax-e (car (syntax-e c))) 'code:comment))
+            (advance c init-line!)
+            (out "; " comment-color)
+            (let ([v (syntax-object->datum (cadr (syntax->list c)))])
+              (if (paragraph? v)
+                  (map (lambda (v) (out v comment-color)) (paragraph-content v))
+                  (out v comment-color)))]
+           [(and (pair? (syntax-e c))
+                 (eq? (syntax-e (car (syntax-e c))) 'code:contract))
+            (advance c init-line!)
+            (out "; " comment-color)
+            (let* ([l (cdr (syntax->list c))]
+                   [s-col (or (syntax-column (car l)) src-col)])
+              (set! src-col s-col)
+              (for-each (loop (lambda ()
+                                (set! src-col s-col)
+                                (set! dest-col 0)
+                                (out "; " comment-color))
+                              0)
+                        l))]
+           [(and (pair? (syntax-e c))
+                 (eq? (syntax-e (car (syntax-e c))) 'code:line))
+            (for-each (loop init-line! quote-depth) 
+                      (cdr (syntax->list c)))]
+           [(and (pair? (syntax-e c))
+                 (eq? (syntax-e (car (syntax-e c))) 'code:quote))
+            (advance c init-line!)
+            (out "(" (if (positive? quote-depth) value-color paren-color))
+            (set! src-col (+ src-col 1))
+            (hash-table-put! col-map src-col dest-col)
+            ((loop init-line! quote-depth) 
+             (datum->syntax-object #'here 'quote (car (syntax-e c))))
+            (for-each (loop init-line! (add1 quote-depth))
+                      (cdr (syntax->list c)))
+            (out ")" (if (positive? quote-depth) value-color paren-color))
+            (set! src-col (+ src-col 1))
+            (hash-table-put! col-map src-col dest-col)]
+           [(and (pair? (syntax-e c))
+                 (memq (syntax-e (car (syntax-e c))) 
+                       '(quote quasiquote unquote unquote-splicing
+                               syntax unsyntax)))
+            (advance c init-line!)
+            (let-values ([(str quote-delta)
+                          (case (syntax-e (car (syntax-e c)))
+                            [(quote) (values "'" +inf.0)]
+                            [(unquote) (values "," -1)]
+                            [(unquote-splicing) (values ",@" -1)]
+                            [(quasiquote) (values "`" +1)]
+                            [(syntax) (values "#'" 0)]
+                            [(unsyntax) (values "#," 0)])])
+              (out str (if (positive? (+ quote-depth quote-delta))
+                           value-color
+                           meta-color))
+              (let ([i (cadr (syntax->list c))])
+                (set! src-col (or (syntax-column i) src-col))
+                (hash-table-put! col-map src-col dest-col)
+                ((loop init-line! (+ quote-depth quote-delta)) i)))]
+           [(and (pair? (syntax-e c))
+                 (convert-infix c quote-depth))
+            => (lambda (converted)
+                 ((loop init-line! quote-depth) converted))]
+           [(pair? (syntax-e c))
+            (let* ([sh (or (syntax-property c 'paren-shape)
+                           #\()]
+                   [p-color (if (positive? quote-depth) 
+                                value-color
+                                (if (eq? sh #\?)
+                                    opt-color
+                                    paren-color))])
+              (advance c init-line!)
+              (out (case sh
+                     [(#\[ #\?) "["]
+                     [(#\{) "{"]
+                     [else "("])
+                   p-color)
+              (set! src-col (+ src-col 1))
+              (hash-table-put! col-map src-col dest-col)
+              (let lloop ([l c])
+                (cond
+                 [(and (syntax? l)
+                       (pair? (syntax-e l)))
+                  (lloop (syntax-e l))]
+                 [(or (null? l)
+                      (and (syntax? l)
+                           (null? (syntax-e l))))
+                  (void)]
+                 [(pair? l)
+                  ((loop init-line! quote-depth) (car l))
+                  (lloop (cdr l))]
+                 [else
+                  (out " . " (if (positive? quote-depth) value-color paren-color))
+                  (set! src-col (+ src-col 3))
+                  (hash-table-put! col-map src-col dest-col)
+                  ((loop init-line! quote-depth) l)]))
+              (out (case sh
+                     [(#\[ #\?) "]"]
+                     [(#\{) "}"]
+                     [else ")"])
+                   p-color)
+              (set! src-col (+ src-col 1))
+              (hash-table-put! col-map src-col dest-col))]
+           [else
+            (advance c init-line!)
+            (let-values ([(s it? sub?)
+                          (let ([c (syntax-e c)])
+                            (let ([s (format "~s" c)])
+                              (if (and (symbol? c)
+                                       (char=? (string-ref s 0) #\_))
+                                  (values (substring s 1) #t #f)
+                                  (values s #f #f))))])
+              (if (element? (syntax-e c))
+                  (out (syntax-e c) no-color)
+                  (out (if (and (identifier? c)
+                                color?
+                                (quote-depth . <= . 0)
+                                (not it?))
+                           (make-delayed-element
+                            (lambda (renderer sec ht)
+                              (let* ([vtag (register-scheme-definition (syntax-e c))]
+                                     [stag (register-scheme-form-definition (syntax-e c))]
+                                     [vd (hash-table-get ht vtag #f)]
+                                     [sd (hash-table-get ht stag #f)])
+                                (list
+                                 (cond
+                                  [sd 
+                                   (make-link-element "schemesyntaxlink" (list s) stag)]
+                                  [vd
+                                   (make-link-element "schemevaluelink" (list s) vtag)]
+                                  [else s])))))
+                           s)
+                       (cond
+                        [(positive? quote-depth) value-color]
+                        [(or (number? (syntax-e c))
+                             (string? (syntax-e c))
+                             (bytes? (syntax-e c))
+                             (char? (syntax-e c))
+                             (boolean? (syntax-e c)))
+                         value-color]
+                        [(identifier? c) 
+                         (cond
+                          [(memq (syntax-e c) (current-keyword-list))
+                           keyword-color]
+                          [(memq (syntax-e c) (current-variable-list))
+                           variable-color]
+                          [it? variable-color]
+                          [else symbol-color])]
+                        [else paren-color])))
+              (hash-table-put! col-map src-col dest-col))])))
+      (hash-table-put! col-map src-col dest-col)
+      (out prefix1 no-color)
+      ((loop (lambda () (set! src-col init-col) (set! dest-col 0)) 0) c)
+      (unless (null? content)
+        (finish-line!))
+      (if multi-line?
+          (make-table #f (map list (reverse docs)))
+          (make-element #f (reverse content)))))
+
+  (define (to-element c)
+    (typeset c #f "" "" #t))
+
+  (define (to-element/no-color c)
+    (typeset c #f "" "" #f))
+
+  (define (to-paragraph c)
+    (typeset c #t "" "" #t))
+
+  (define ((to-paragraph/prefix pfx1 pfx) c)
+    (typeset c #t pfx1 pfx #t))
+
+  (define-syntax (define-code stx)
+    (syntax-case stx ()
+      [(_ code typeset-code uncode d->s)
+       (syntax/loc stx
+	 (define-syntax (code stx)
+	   (define (stx->loc-s-expr v)
+	     (cond
+	      [(syntax? v)
+	       (let ([mk `(d->s
+			   #f
+			   ,(syntax-case v (uncode)
+			      [(uncode e) #'e]
+			      [else (stx->loc-s-expr (syntax-e v))])
+			   (list 'code
+				 ,(syntax-line v)
+				 ,(syntax-column v)
+				 ,(syntax-position v)
+				 ,(syntax-span v)))])
+		 (let ([prop (syntax-property v 'paren-shape)])
+		   (if prop
+		       `(syntax-property ,mk 'paren-shape ,prop)
+		       mk)))]
+	      [(pair? v) `(cons ,(stx->loc-s-expr (car v))
+				,(stx->loc-s-expr (cdr v)))]
+	      [(vector? v) `(vector ,@(map
+				       stx->loc-s-expr
+				       (vector->list v)))]
+	      [(box? v) `(box ,(stx->loc-s-expr (unbox v)))]
+	      [(null? v) 'null]
+	      [else `(quote ,v)]))
+	   (define (cvt s)
+	     (d->s #'here (stx->loc-s-expr s) #f))
+	   (syntax-case stx ()
+	     [(_ expr) #`(typeset-code #,(cvt #'expr))]
+	     [(_ expr (... ...))
+	      #`(typeset-code #,(cvt #'(code:line expr (... ...))))])))]
+      [(_ code typeset-code uncode)
+       #'(define-code code typeset-code uncode datum->syntax-object)]
+      [(_ code typeset-code) #'(define-code code typeset-code unsyntax)]))
+
+  
+  (define (register-scheme-definition sym)
+    (format "definition:~s" sym))
+
+  (define (register-scheme-form-definition sym)
+    (format "formdefinition:~s" sym))
+
+  (define syntax-ize-hook (make-parameter (lambda (v col) #f)))
+
+  (define (syntax-ize v col)
+    (cond
+     [((syntax-ize-hook) v col)
+      => (lambda (r) r)]
+     [(and (list? v)
+           (pair? v)
+           (memq (car v) '(quote unquote unquote-splicing)))
+      (let ([c (syntax-ize (cadr v) (+ col 1))])
+        (datum->syntax-object #f
+                              (list (syntax-ize (car v) col)
+                                    c)
+                              (list #f 1 col (+ 1 col)
+                                    (+ 1 (syntax-span c)))))]
+     [(list? v)
+      (let ([l (let loop ([col (+ col 1)]
+                          [v v])
+                 (if (null? v)
+                     null
+                     (let ([i (syntax-ize (car v) col)])
+                       (cons i
+                             (loop (+ col 1 (syntax-span i)) (cdr v))))))])
+        (datum->syntax-object #f
+                              l
+                              (list #f 1 col (+ 1 col)
+                                    (+ 2
+                                       (sub1 (length l))
+                                       (apply + (map syntax-span l))))))]
+     [(pair? v)
+      (let* ([a (syntax-ize (car v) (+ col 1))]
+             [sep (if (pair? (cdr v)) 0 3)]
+             [b (syntax-ize (cdr v) (+ col 1 (syntax-span a) sep))])
+        (datum->syntax-object #f
+                              (cons a b)
+                              (list #f 1 col (+ 1 col)
+                                    (+ 2 sep (syntax-span a) (syntax-span b)))))]
+     [else
+      (datum->syntax-object #f v (list #f 1 col (+ 1 col) 1))])))

collects/scribble/scribble.css

@@ -0,0 +1,241 @@
+
+               body {
+               color: black;
+               /*   background-color: #e5e5e5;*/
+               background-color: #ffffff;
+               /*background-color: beige;*/
+               margin-top: 2em;
+               margin-left: 8%;
+               margin-right: 8%;
+               }
+
+               h1,h2,h3,h4,h5,h6 {
+               margin-top: .5em;
+               }
+
+               .toclink { 
+               text-decoration: none;
+               color: blue;
+               }
+
+               .title {
+               font-size: 200%;
+               font-weight: normal;
+               margin-top: 2.8em;
+               text-align: center;
+               }
+
+               .partheading {
+               font-size: 100%;
+               }
+
+               .chapterheading {
+               font-size: 100%;
+               }
+
+               .beginsection {
+               font-size: 110%;
+               }
+
+               .tiny {
+               font-size: 40%;
+               }
+
+               .scriptsize {
+               font-size: 60%;
+               }
+
+               .footnotesize {
+               font-size: 75%;
+               }
+
+               .small {
+               font-size: 90%;
+               }
+
+               .normalsize {
+               font-size: 100%;
+               }
+
+               .large {
+               font-size: 120%;
+               }
+
+               .largecap {
+               font-size: 150%;
+               }
+
+               .largeup {
+               font-size: 200%;
+               }
+
+               .huge {
+               font-size: 300%;
+               }
+
+               .hugecap {
+               font-size: 350%;
+               }
+
+               pre {
+               margin-left: 2em;
+               }
+
+               blockquote {
+               margin-left: 2em;
+               }
+
+               ol {
+               list-style-type: decimal;
+               }
+
+               ol ol {
+               list-style-type: lower-alpha;
+               }
+
+               ol ol ol {
+               list-style-type: lower-roman;
+               }
+
+               ol ol ol ol {
+               list-style-type: upper-alpha;
+               }
+
+               tt i {
+               font-family: serif;
+               }
+
+               .verbatim em {
+               font-family: serif;
+               }
+
+               /*
+               .verbatim {
+               color: #4d0000;
+               }
+               */
+
+               .scheme em {
+               color: black;
+               font-family: serif;
+               }
+
+               .schemeinput {
+               color: brown;
+               background-color: #eeeeee;
+               font-family: monospace;
+               }
+
+               .schemeparen {
+               color: brown;
+               font-family: monospace;
+               }
+
+               .schemeopt {
+               color: black;
+               }
+
+               .schemekeyword {
+               color: black;
+               font-weight: bold;
+               font-family: monospace;
+               }
+
+               .schemeerror {
+               color: red;
+               font-style: italic;             
+               }
+
+               .schemevariable {
+               color: navy;
+               font-style: italic;             
+               font-family: monospace;
+               }
+
+               .schemesymbol {
+               color: navy;
+               font-family: monospace;
+               }
+
+               .schemevaluelink { 
+               text-decoration: none;
+               color: blue;
+               font-family: monospace;
+               }
+
+               .schemesyntaxlink { 
+               text-decoration: none;
+               color: black;
+               font-weight: bold;
+               font-family: monospace;
+               }
+
+               .badlink { 
+               text-decoration: underline;
+               color: red;
+               }
+
+               .schemeresult {
+               color: navy;
+               font-family: monospace;
+               }
+
+               .schemestdout {
+               color: purple;
+               font-family: monospace;
+               }
+
+               .schemecomment {
+               color:  teal;
+               font-family: monospace;
+               }
+
+               .schemevalue {
+               color: green;
+               font-family: monospace;
+               }
+
+               .navigation {
+               color: red;
+               text-align: right;
+               font-size: medium;
+               font-style: italic;
+               }
+
+               .disable {
+               /* color: #e5e5e5; */
+               color: gray;
+               }
+
+               .smallcaps {
+               font-size: 75%;
+               }
+
+               .smallprint {
+               color: gray;
+               font-size: 75%;
+               text-align: right;
+               }
+
+               /*
+               .smallprint hr {
+               text-align: left;
+               width: 40%;
+               }
+               */
+
+               .footnoterule {
+               text-align: left;
+               width: 40%;
+               }
+
+               .colophon {
+               color: gray;
+               font-size: 80%;
+               font-style: italic;
+               text-align: right;
+               }
+
+               .colophon a {
+               color: gray;
+               }

collects/scribble/struct.ss

@@ -0,0 +1,148 @@
+
+(module struct mzscheme
+  (require (lib "contract.ss")
+           (lib "serialize.ss"))
+
+  (provide provide-structs)
+
+  (define-syntax (provide-structs stx)
+    (syntax-case stx ()
+      [(_ (id ([field ct] ...)) ...)
+       #`(begin
+           (define-serializable-struct id (field ...)) ...
+           (provide/contract
+            #,@(let ([ids (syntax->list #'(id ...))]
+                     [fields+cts (syntax->list #'(([field ct] ...) ...))])
+                 (letrec ([get-fields (lambda (super-id)
+                                        (ormap (lambda (id  fields+cts)
+                                                 (if (identifier? id)
+                                                     (and (module-identifier=? id super-id)
+                                                          fields+cts)
+                                                     (syntax-case id ()
+                                                       [(my-id next-id)
+                                                        (module-identifier=? #'my-id super-id)
+                                                        #`[#,@(get-fields #'next-id)
+                                                           #,@fields+cts]]
+                                                       [_else #f])))
+                                               ids fields+cts))])
+                   (map (lambda (id fields+cts)
+                          (if (identifier? id)
+                              #`[struct #,id #,fields+cts]
+                              (syntax-case id ()
+                                [(id super)
+                                 #`[struct id (#,@(get-fields #'super) 
+                                               #,@fields+cts)]])))
+                        ids
+                        fields+cts)))))]))
+
+  (provide tag?)
+  (define (tag? s) (or (string? s)
+                       (and (pair? s)
+                            (symbol? (car s))
+                            (pair? (cdr s))
+                            (string? (cadr s))
+                            (null? (cddr s)))))
+
+  (provide flow-element?)
+  (define (flow-element? p)
+    (or (paragraph? p)
+        (table? p)
+        (itemization? p)
+        (delayed-flow-element? p)))
+
+  (provide-structs 
+   [part ([tag (or/c false/c tag?)]
+          [title-content (or/c false/c list?)]
+          [collected-info (or/c false/c collected-info?)]
+          [flow flow?]
+          [parts (listof part?)])]
+   [(unnumbered-part part) ()]
+   [flow ([paragraphs (listof flow-element?)])]
+   [paragraph ([content list?])]
+   [table ([style any/c]
+           [flowss (listof (listof flow?))])]
+   [delayed-flow-element ([render (any/c part? any/c . -> . flow-element?)])]
+   [itemization ([flows (listof flow?)])]
+   ;; content = list of elements
+   [element ([style any/c]
+             [content list?])]
+   [(target-element element) ([tag tag?])]
+   [(link-element element) ([tag tag?])]
+   [(index-element element) ([tag tag?]
+                             [plain-seq (listof string?)]
+                             [entry-seq list?])]
+   ;; specific renders support other elements, especially strings
+
+   [collected-info ([number (listof (or/c false/c integer?))]
+                    [parent (or/c false/c part?)]
+                    [info any/c])]
+
+   [target-url ([addr string?])]
+   [image-file ([path path-string?])])
+
+  ;; ----------------------------------------
+
+  ;; Delayed element has special serialization support:
+  (define-values (struct:delayed-element
+                  make-delayed-element
+                  delayed-element?
+                  delayed-element-ref
+                  delayed-element-set!)
+    (make-struct-type 'delayed-element #f
+                      1 1 #f
+                      (list (cons prop:serializable 
+                                  (make-serialize-info
+                                   (lambda (d)
+                                     (unless (delayed-element-ref d 1)
+                                       (error 'serialize-delayed-element
+                                              "cannot serialize a delayed element that was not resolved: ~e"
+                                              d))
+                                     (vector (delayed-element-ref d 1)))
+                                   #'deserialize-delayed-element
+                                   #f
+                                   (or (current-load-relative-directory) (current-directory)))))))
+  (define-syntax delayed-element (list-immutable #'struct:delayed-element
+                                                 #'make-delayed-element
+                                                 #'delayed-element?
+                                                 (list-immutable #'delayed-element-render)
+                                                 (list-immutable #'set-delayed-element-render!)
+                                                 #t))
+  (define delayed-element-render (make-struct-field-accessor delayed-element-ref 0))
+  (define set-delayed-element-render! (make-struct-field-mutator delayed-element-set! 0))
+  (provide/contract
+   (struct delayed-element ([render (any/c part? any/c . -> . list?)])))
+
+  (provide deserialize-delayed-element)
+  (define deserialize-delayed-element
+    (make-deserialize-info values values))
+  
+  (provide force-delayed-element)
+  (define (force-delayed-element d renderer sec ht)
+    (or (delayed-element-ref d 1)
+        (let ([v ((delayed-element-ref d 0) renderer sec ht)])
+          (delayed-element-set! d 1 v)
+          v)))
+
+  ;; ----------------------------------------
+
+  (provide content->string)
+
+  (define (content->string c)
+    (apply string-append
+           (map (lambda (e)
+                  (element->string e))
+                c)))
+
+  (define (element->string c)
+    (cond
+     [(element? c) (content->string (element-content c))]
+     [(string? c) c]
+     [else (case c
+             [(ndash) "--"]
+             [(ldquo rdquo) "\""]
+             [(rsquo) "'"]
+             [(rarr) "->"]
+             [else (format "~s" c)])]))
+
+  )
+

collects/scribble/text-render.ss

@@ -0,0 +1,97 @@
+
+(module text-render mzscheme
+  (require "struct.ss"
+           (lib "class.ss"))
+  (provide render-mixin)
+
+  (define (render-mixin %)
+    (class %
+      (define/override (get-substitutions)
+        '((#rx"---" "\U2014")
+	  (#rx"--" "\U2013")
+	  (#rx"``" "\U201C")
+	  (#rx"''" "\U201D")
+	  (#rx"'" "\U2019")))
+
+      (inherit render-content
+               render-paragraph
+               render-flow-element)
+
+      (define/override (render-part d ht)
+        (let ([number (collected-info-number (part-collected-info d))])
+          (when (or (ormap values number)
+                    (part-title-content d))
+            (newline))
+          (for-each (lambda (n)
+                      (when n
+                        (printf "~s." n)))
+                    (reverse number))
+          (when (part-title-content d)
+            (when (ormap values number)
+              (printf " "))
+            (render-content (part-title-content d) d ht))
+          (when (or (ormap values number)
+                    (part-title-content d))
+            (newline))
+          (newline)
+          (render-flow (part-flow d) d ht)
+          (let loop ([pos 1]
+                     [secs (part-parts d)])
+            (unless (null? secs)
+              (newline)
+              (render-part (car secs) ht)
+              (loop (add1 pos) (cdr secs))))))
+
+      (define/override (render-flow f part ht)
+        (let ([f (flow-paragraphs f)])
+          (if (null? f)
+              null
+              (apply
+               append
+               (render-flow-element (car f) part ht)
+               (map (lambda (p)
+                      (newline) (newline)
+                      (render-flow-element p part ht))
+                    (cdr f))))))
+
+      (define/override (render-table i part ht)
+        (let ([flowss (table-flowss i)])
+          (if (null? flowss)
+              null
+              (apply
+               append
+               (map (lambda (d) (render-flow d part ht)) (car flowss))
+               (map (lambda (flows)
+                      (newline)
+                      (map (lambda (d) (render-flow d part ht)) flows))
+                    (cdr flowss))))))
+
+      (define/override (render-itemization i part ht)
+        (let ([flows (itemization-flows i)])
+          (if (null? flows)
+              null
+              (apply append
+                     (begin
+                       (printf "* ")
+                       (render-flow (car flows) part ht))
+                     (map (lambda (d)
+                            (printf "\n\n* ")
+                            (render-flow d part ht))
+                          (cdr flows))))))
+      
+      (define/override (render-other i part ht)
+        (cond
+         [(symbol? i)
+          (display (case i
+                     [(mdash) "\U2014"]
+                     [(ndash) "\U2013"]
+                     [(ldquo) "\U201C"]
+                     [(rdquo) "\U201D"]
+                     [(rsquo) "\U2019"]
+                     [(rarr) "->"]
+                     [else (error 'text-render "unknown element symbol: ~e" i)]))]
+         [(string? i) (display i)]
+         [else (write i)])
+        null)
+
+      (super-new))))

collects/scribble/urls.ss

@@ -0,0 +1,8 @@
+
+(module urls mzscheme
+  (provide (all-defined))
+
+  (define url:drscheme "http://www.drscheme.org/")
+  (define url:download-drscheme "http://download.plt-scheme.org/drscheme/")
+  
+  (define url:planet "http://planet.plt-scheme.org/"))