(module manual scheme/base
  (require "decode.ss"
           "struct.ss"
           "scheme.ss"
           "config.ss"
           "basic.ss"
           "manual-struct.ss"
           mzlib/string
           scheme/class
           scheme/stxparam
           mzlib/serialize
           (for-syntax scheme/base)
           (for-label scheme/base
                      scheme/class))

  (provide (all-from-out "basic.ss")
           unsyntax)

  (provide PLaneT)
  (define PLaneT "PLaneT")

  (provide etc)
  (define etc "etc.") ; so we can fix the latex space, one day

  (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
                              #'here
                              `(unsyntax (make-element
                                          #f
                                          (list hash-lang
                                                (hspace 1)
                                                (as-modname-link
                                                 ',#'lang
                                                 (to-element ',#'lang)))))
                              #'lang)])
         #'(schemeblock modtag 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-syntax (keep-s-expr stx)
    (syntax-case stx ()
      [(_ ctx s srcloc)
       (let ([sv (syntax-e #'s)])
         (if (or (number? sv)
                 (boolean? sv)
                 (and (pair? sv)
                      (identifier? (car sv))
                      (free-identifier=? #'cons (car sv))))
             ;; We know that the context is irrelvant
             #'s
             ;; Context may be relevant:
             #'(*keep-s-expr s ctx)))]))
  (define (*keep-s-expr s ctx)
    (if (symbol? s)
        (make-just-context s ctx)
        s))

  (define (add-sq-prop s name val)
    (if (eq? name 'paren-shape)
        (make-shaped-parens s val)
        s))

  (define-code scheme to-element unsyntax keep-s-expr add-sq-prop)
  (define-code SCHEME to-element UNSYNTAX keep-s-expr add-sq-prop)
  (define-code schemeresult to-element/result unsyntax keep-s-expr add-sq-prop)
  (define-code schemeid to-element/id unsyntax keep-s-expr add-sq-prop)
  (define-code *schememodname to-element unsyntax keep-s-expr add-sq-prop)

  (define-syntax-rule (schememodname n)
    (as-modname-link 'n (*schememodname n)))

  (define (as-modname-link s e)
    (if (symbol? s)
        (make-link-element "schememodlink"
                           (list e)
                           `(mod-path ,(symbol->string s)))
        e))

  (define-syntax-rule (defmodule*/no-declare (name ...) . content)
    (*defmodule (list (schememodname name) ...)
                #f
                (list . content)))

  (define-syntax-rule (defmodule* (name ...) . content)
    (begin
      (declare-exporting name ...)
      (defmodule*/no-declare (name ...) . content)))

  (define-syntax-rule (defmodule name . content)
    (defmodule* (name) . content))
  
  (define-syntax-rule (defmodulelang*/no-declare (lang ...) . content)
    (*defmodule (list (schememodname lang) ...)
                #t
                (list . content)))

  (define-syntax-rule (defmodulelang* (name ...) . content)
    (begin
      (declare-exporting name ...)
      (defmodulelang*/no-declare (name ...) . content)))

  (define-syntax-rule (defmodulelang lang . content)
    (defmodulelang* (lang) . content))

  (define (*defmodule names lang? content)
    (make-splice
     (cons
      (make-table
       "defmodule"
       (map (lambda (name)
              (list
               (make-flow
                (list (make-paragraph
                       (if lang?
                           (list (hspace 1)
                                 hash-lang
                                 (hspace 1)
                                 (make-defschememodname name))
                           (list
                            (hspace 1)
                            (scheme (require #,(make-defschememodname name))))))))))
            names))
      (append
       (map (lambda (name)
              (make-part-tag-decl `(mod-path ,(element->string name))))
            names)
       (flow-paragraphs (decode-flow content))))))
  
  (define (make-defschememodname mn)
    (let ([name-str (element->string mn)])
      (make-index-element #f
                          (list mn)
                          `(mod-path ,name-str)
                          (list name-str)
                          (list mn)
                          (make-module-path-index-desc))))

  (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))])
      (if (regexp-match? #rx"^ *$" s)
          (make-element "schemeinputbg" (list (hspace (string-length s))))
          (let ([spaces (regexp-match-positions #rx"^ *" s)]
                [end-spaces (regexp-match-positions #rx" *$" s)])
            (make-element
             "schemeinputbg"
             (list (hspace (cdar spaces))
                   (make-element "schemeinput" (list (substring s (cdar spaces) (caar end-spaces))))
                   (hspace (- (cdar end-spaces) (caar end-spaces)))))))))

  (define (verbatim s)
    (let ([strs (regexp-split #rx"\n" s)])
      (make-table
       #f
       (map (lambda (s)
              (list (make-flow (list (make-paragraph 
                                      (let loop ([s s])
                                        (let ([spaces (regexp-match-positions #rx"(?:^| ) +" s)])
                                          (if spaces
                                              (append
                                               (loop (substring s 0 (caar spaces)))
                                               (list (hspace (- (cdar spaces) (caar spaces))))
                                               (loop (substring s (cdar spaces))))
                                              (list (make-element 'tt (list s)))))))))))
            strs))))

  (define-syntax indexed-scheme
    (syntax-rules ()
      [(_ x) (add-scheme-index 'x (scheme x))]))

  (define (add-scheme-index s e)
    (let ([k (cond
              [(and (pair? s)
                    (eq? (car s) 'quote))
               (format "~s" (cadr s))]
              [(string? s) s]
              [else (format "~s" s)])])
      (index* (list k) (list e) e)))

  (define-syntax define-/form
    (syntax-rules ()
      [(_ id base)
       (define-syntax (id stx)
         (syntax-case stx ()
           [(_ a)
            (with-syntax ([ellipses (datum->syntax #'a
                                                   '(... ...))])
              #'(let ([ellipses #f])
                  (base a)))]))]))

  (define-/form schemeblock0/form schemeblock0)
  (define-/form schemeblock/form schemeblock)
  (define-/form scheme/form scheme)
  
  (provide schemeblock SCHEMEBLOCK schemeblock/form
           schemeblock0 SCHEMEBLOCK0 schemeblock0/form
           schemeinput
           schememod
           scheme SCHEME scheme/form schemeresult schemeid schememodname
           defmodule defmodule* defmodulelang defmodulelang*
           defmodule*/no-declare defmodulelang*/no-declare
           indexed-scheme
           litchar
           verbatim)

  (provide image onscreen menuitem defterm
           schemefont schemevalfont schemeresultfont schemeidfont schemevarfont 
           schemeparenfont schemekeywordfont schememetafont schememodfont
           filepath exec envvar Flag DFlag PFlag DPFlag
           indexed-file indexed-envvar
           link procedure
           idefterm)

  ;; String String *-> Element
  ;; an in-lined image, relative to the current directory 
  (define (image filename-relative-to-source . alt)
    (centerline ;; this doesn't do anything? 
      (make-element
	(make-image-file filename-relative-to-source)
	(decode-content alt))))

  (define (onscreen . str)
    (make-element 'sf (decode-content str)))
  (define (menuitem menu item)
    (make-element 'sf (list menu "|" item)))
  (define (defterm . str)
    (make-element 'italic (decode-content str)))
  (define (idefterm . str)
    (let ([c (decode-content str)])
      (make-element 'italic c)))
  (define (schemefont . str)
    (apply tt str))
  (define (schemevalfont . str)
    (make-element "schemevalue" (decode-content str)))
  (define (schemeresultfont . str)
    (make-element "schemeresult" (decode-content str)))
  (define (schemeidfont . str)
    (make-element "schemesymbol" (decode-content str)))
  (define (schemevarfont . str)
    (make-element "schemevariable" (decode-content str)))
  (define (schemeparenfont . str)
    (make-element "schemeparen" (decode-content str)))
  (define (schememetafont . str)
    (make-element "schememeta" (decode-content str)))
  (define (schememodfont . str)
    (make-element "schememod" (decode-content str)))
  (define (schemekeywordfont . str)
    (make-element "schemekeyword" (decode-content str)))
  (define (filepath . str)
    (make-element 'tt (append (list "\"") (decode-content str) (list "\""))))
  (define (indexed-file . str)
    (let* ([f (apply filepath str)]
           [s (element->string f)])
      (index* (list (substring s 1 (sub1 (string-length s)))) (list f) f)))
  (define (exec . str)
    (make-element 'tt (decode-content str)))
  (define (Flag . str)
    (make-element 'no-break (list (make-element 'tt (cons "-" (decode-content str))))))
  (define (DFlag . str)
    (make-element 'no-break (list (make-element 'tt (cons "--" (decode-content str))))))
  (define (PFlag . str)
    (make-element 'no-break (list (make-element 'tt (cons "+" (decode-content str))))))
  (define (DPFlag . str)
    (make-element 'no-break (list (make-element 'tt (cons "++" (decode-content str))))))
  (define (envvar . str)
    (make-element 'tt (decode-content str)))
  (define (indexed-envvar . str)
    (let* ([f (apply envvar str)]
           [s (element->string f)])
      (index* (list s) (list f) f)))
  (define (procedure . str)
    (make-element "schemeresult" (append (list "#<procedure:") (decode-content str) (list ">"))))

  (define (link url . str)
    (make-element (make-target-url url) (decode-content str)))

  (provide t)
  (define (t . str)
    (decode-paragraph str))

  ;; ----------------------------------------

  (define-struct sig (tagstr))

  (define (definition-site name stx-id form?)
    (let ([sig (current-signature)])
      (if sig
          (make-link-element (if form?
                                 "schemesyntaxlink" 
                                 "schemevaluelink")
                             (list (schemefont (symbol->string name)))
                             `(,(if form? 'sig-form 'sig-val)
                               ,(format "~a::~a" (sig-tagstr sig) name)))
          (annote-exporting-library
           (to-element (make-just-context name stx-id))))))

  (define (id-to-tag id)
    (add-signature-tag id #f))

  (define (id-to-form-tag id)
    (add-signature-tag id #t))

  (define (add-signature-tag id form?)
    (let ([sig (current-signature)])
      (if sig
          `(,(if form? 'sig-form 'sig-val)
            ,(format "~a::~a" (sig-tagstr sig) (syntax-e id)))
          (if form?
              (register-scheme-form-definition id)
              (register-scheme-definition id #t)))))

  (define current-signature (make-parameter #f))

  (define-syntax-rule (sigelem sig elem)
    (*sig-elem (quote-syntax sig) 'elem))

  (define (*sig-elem sig elem)
    (let ([s (to-element elem)]
          [tag (format "~a::~a" 
                       (register-scheme-form-definition sig #t)
                       elem)])
      (make-delayed-element
       (lambda (renderer sec ri)
         (let* ([vtag `(sig-val ,tag)]
                [stag `(sig-form ,tag)]
                [sd (resolve-get/tentative sec ri stag)])
           (list
            (cond
             [sd 
              (make-link-element "schemesyntaxlink" (list s) stag)]
             [else
              (make-link-element "schemevaluelink" (list s) vtag)]))))
       (lambda () s)
       (lambda () s))))

  (provide sigelem)

  ;; ----------------------------------------

  (provide method xmethod (rename-out [method ::]))

  (define-syntax method
    (syntax-rules ()
      [(_ a b)
       (*method 'b (quote-syntax a))]))

  (define-syntax xmethod
    (syntax-rules ()
      [(_ a b)
       (elem (method a b) " in " (scheme a))]))

  (define (*method sym id)
    (**method sym (id-to-tag id)))

  (define (**method sym tag)
    (make-element
     "schemesymbol"
     (list (make-link-element
            "schemevaluelink"
            (list (symbol->string sym))
            (method-tag tag sym)))))

  (define (method-tag vtag sym)
    (list 'meth
          (format "~a::~a" (cadr vtag) sym)))

  ;; ----------------------------------------

  (provide margin-note)
  
  (define (margin-note . c)
    (make-styled-paragraph (list (make-element "refcolumn"
                                               (list
                                                (make-element "refcontent"
                                                              c))))
                           "refpara"))

  ;; ----------------------------------------

  (provide deftech tech techlink)

  (define (*tech make-elem style doc s)
    (let* ([c (decode-content s)]
           [s (regexp-replace* #px"[-\\s]+" 
                               (regexp-replace 
                                #rx"s$" 
                                (regexp-replace 
                                 #rx"ies$" 
                                 (string-foldcase (content->string c))
                                 "y")
                                "")
                               " ")])
      (make-elem style
                 c
                 (list 'tech (doc-prefix doc s)))))

  (define (deftech . s)
    (let* ([e (apply defterm s)]
           [t (*tech make-target-element #f #f (list e))])
      (make-index-element #f
                          (list t)
                          (target-element-tag t)
                          (list (element->string e))
                          (list e)
                          'tech)))

  (define (tech #:doc [doc #f] . s)
    (*tech make-link-element "techlink" doc s))

  (define (techlink #:doc [doc #f] . s)
    (*tech make-link-element #f doc s))

  ;; ----------------------------------------

  (provide declare-exporting
           deftogether
           defproc defproc* defstruct defthing defthing* defparam defparam* defboolparam
           defform defform* defform/subs defform*/subs defform/none
           defidform
           specform specform/subs 
           specsubform specsubform/subs specspecsubform specspecsubform/subs specsubform/inline
           defsubform
           schemegrammar schemegrammar*
           var svar void-const undefined-const)

  (define-syntax declare-exporting
    (syntax-rules ()
      [(_ lib ...) (*declare-exporting '(lib ...))]))

  (define (*declare-exporting libs)
    (make-part-collect-decl
     (make-collect-element #f
                           null
                           (lambda (ri)
                             (collect-put! ri '(exporting-libraries #f)libs)))))

  (define-syntax (quote-syntax/loc stx)
    (syntax-case stx ()
      [(_ id) 
       (with-syntax ([loc
                      (let ([s #'id])
                        (list (syntax-source s)
                              (syntax-line s)
                              (syntax-column s)
                              (syntax-position s)
                              (syntax-span s)))])
         #'(let ([s (quote-syntax id)])
             (datum->syntax s
                            (syntax-e s)
                            'loc
                            s)))]))

  (define void-const
    (schemeresultfont "#<void>"))
  (define undefined-const
    (schemeresultfont "#<undefined>"))

  (define dots0
    (make-element "schememeta" (list "...")))
  (define dots1
    (make-element "schememeta" (list "...+")))

  (define-syntax (arg-contract stx)
    (syntax-case stx (... ...+ _...superclass-args...)
      [(_ [id contract])
       (identifier? #'id)
       #'(schemeblock0 contract)]
      [(_ [id contract val])
       (identifier? #'id)
       #'(schemeblock0 contract)]
      [(_ [kw id contract])
       (and (keyword? (syntax-e #'kw))
            (identifier? #'id))
       #'(schemeblock0 contract)]
      [(_ [kw id contract val])
       (and (keyword? (syntax-e #'kw))
            (identifier? #'id))
       #'(schemeblock0 contract)]
      [(_ (... ...))
       #'#f]
      [(_ (... ...+))
       #'#f]
      [(_ _...superclass-args...)
       #'#f]
      [(_ arg)
       (raise-syntax-error
        'defproc
        "bad argument form"
        #'arg)]))

  (define-syntax (arg-default stx)
    (syntax-case stx (... ...+ _...superclass-args...)
      [(_ [id contract])
       (identifier? #'id)
       #'#f]
      [(_ [id contract val])
       (identifier? #'id)
       #'(schemeblock0 val)]
      [(_ [kw id contract])
       (keyword? (syntax-e #'kw))
       #'#f]
      [(_ [kw id contract val])
       (keyword? (syntax-e #'kw))
       #'(schemeblock0 val)]
      [else
       #'#f]))

  (define-syntax (extract-proc-id stx)
    (syntax-case stx ()
      [(_ id)
       (identifier? #'id)
       #`(quote-syntax/loc id)]
      [(_ (proto arg ...))
       #'(extract-proc-id proto)]
      [(_ thing)
       (raise-syntax-error
        'defproc
        "bad prototype"
        #'thing)]))
  
  (define-syntax (arg-contracts stx)
    (syntax-case stx ()
      [(_ id arg ...)
       (identifier? #'id)
       #'(list (lambda () (arg-contract arg)) ...)]
      [(_ (proto arg1 ...) arg ...)
       #'(arg-contracts proto arg1 ... arg ...)]
      [_
       (raise-syntax-error 'defproc "bad prototype" stx)]))
  
  (define-syntax (arg-defaults stx)
    (syntax-case stx ()
      [(_ id arg ...)
       (identifier? #'id)
       #'(list (lambda () (arg-default arg)) ...)]
      [(_ (proto arg1 ...) arg ...)
       #'(arg-defaults proto arg1 ... arg ...)]
      [_
       (raise-syntax-error 'defproc "bad prototype" stx)]))

  (define-syntax (result-contract stx)
    (syntax-case stx ()
      [(_ c)
       (if (string? (syntax-e #'c))
           (raise-syntax-error
            'defproc
            "expected a result contract, found a string"
            #'c)
           #'(schemeblock0 c))]))

  (define-syntax defproc 
    (syntax-rules ()
      [(_ (id arg ...) result desc ...)
       (defproc* [[(id arg ...) result]] desc ...)]))
  (define-syntax defproc*
    (syntax-rules ()
      [(_ [[proto result] ...] desc ...)
       (defproc* #:mode procedure #:within #f [[proto result] ...] desc ...)]
      [(_ #:mode m #:within cl [[proto result] ...] desc ...)
       (*defproc 'm (quote-syntax/loc cl)
                 (list (extract-proc-id proto) ...)
                 '[proto ...] 
                 (list (arg-contracts proto) ...)
                 (list (arg-defaults proto) ...)
                 (list (lambda () (result-contract result)) ...)
                 (lambda () (list desc ...)))]))
  (define-syntax defstruct
    (syntax-rules ()
      [(_ name fields #:mutable #:inspector #f desc ...)
       (**defstruct name fields #f #t desc ...)]
      [(_ name fields #:mutable desc ...)
       (**defstruct name fields #f #f desc ...)]
      [(_ name fields #:inspector #f desc ...)
       (**defstruct name fields #t #t desc ...)]
      [(_ name fields desc ...)
       (**defstruct name fields #t #f desc ...)]))
  (define-syntax **defstruct
    (syntax-rules ()
      [(_ name ([field field-contract] ...) immutable? transparent? desc ...)
       (*defstruct (quote-syntax/loc name) 'name 
                   '([field field-contract] ...) (list (lambda () (schemeblock0 field-contract)) ...)
                   immutable? transparent? (lambda () (list desc ...)))]))
  (define-syntax (defform*/subs stx)
    (syntax-case stx ()
      [(_ #:literals (lit ...) [spec spec1 ...] ([non-term-id non-term-form ...] ...) desc ...)
       (with-syntax ([new-spec
                      (syntax-case #'spec ()
                        [(name . rest)
                         (datum->syntax #'spec
                                        (cons
                                         (datum->syntax #'here
                                                        '(unsyntax x)
                                                        #'name)
                                         #'rest)
                                        #'spec)])]
                     [spec-id
                      (syntax-case #'spec ()
                        [(name . rest) #'name])])
         #'(*defforms (quote-syntax/loc spec-id) '(lit ...)
                      '(spec spec1 ...) 
                      (list (lambda (x) (schemeblock0/form new-spec))
                            (lambda (ignored) (schemeblock0/form spec1)) ...)
                      '((non-term-id non-term-form ...) ...)
                      (list (list (lambda () (scheme non-term-id))
                                  (lambda () (schemeblock0/form non-term-form))
                                  ...)
                            ...)
                      (lambda () (list desc ...))))]
      [(fm [spec spec1 ...] ([non-term-id non-term-form ...] ...) desc ...)
       #'(fm #:literals () [spec spec1 ...] ([non-term-id non-term-form ...] ...) desc ...)]))
  (define-syntax (defform* stx)
    (syntax-case stx ()
      [(_ #:literals lits [spec ...] desc ...) #'(defform*/subs #:literals lits [spec ...] () desc ...)]
      [(_ [spec ...] desc ...) #'(defform*/subs [spec ...] () desc ...)]))
  (define-syntax (defform stx)
    (syntax-case stx ()
      [(_ #:literals (lit ...) spec desc ...) #'(defform*/subs #:literals (lit ...) [spec] () desc ...)]
      [(_ spec desc ...) #'(defform*/subs [spec] () desc ...)]))
  (define-syntax (defform/subs stx)
    (syntax-case stx ()
      [(_ #:literals lits spec subs desc ...) #'(defform*/subs #:literals lits [spec] subs desc ...)]
      [(_ spec subs desc ...) #'(defform*/subs [spec] subs desc ...)]))
  (define-syntax (defform/none stx)
    (syntax-case stx ()
      [(_ #:literals (lit ...) spec desc ...)
       #'(*defforms #f '(lit ...)
                    '(spec) (list (lambda (ignored) (schemeblock0/form spec))) 
                    null null
                    (lambda () (list desc ...)))]
      [(_ spec desc ...)
       #'(defform/none #:literals () spec desc ...)]))
  (define-syntax (defidform stx)
    (syntax-case stx ()
      [(_ spec-id desc ...)
       #'(*defforms (quote-syntax/loc spec-id) null
                    '(spec-id)
                    (list (lambda (x) (make-paragraph (list x))))
                    null
                    null
                    (lambda () (list desc ...)))]))
  (define-syntax (defsubform stx)
    (syntax-case stx ()
      [(_ . rest) #'(into-blockquote (defform . rest))]))
  (define-syntax specsubform
    (syntax-rules ()
      [(_ #:literals (lit ...) spec desc ...)
       (*specsubform 'spec #f '(lit ...) (lambda () (schemeblock0/form spec)) null null (lambda () (list desc ...)))]
      [(_ spec desc ...)
       (*specsubform 'spec #f null (lambda () (schemeblock0/form spec)) null null (lambda () (list desc ...)))]))
  (define-syntax specsubform/subs
    (syntax-rules ()
      [(_ #:literals (lit ...) spec ([non-term-id non-term-form ...] ...) desc ...)
       (*specsubform 'spec #f '(lit ...) (lambda () (schemeblock0/form spec)) 
                     '((non-term-id non-term-form ...) ...)
                     (list (list (lambda () (scheme non-term-id))
                                 (lambda () (schemeblock0/form non-term-form))
                                 ...)
                           ...)
                     (lambda () (list desc ...)))]
      [(_ spec subs desc ...)
       (specsubform/subs #:literals () spec subs desc ...)]))
  (define-syntax specspecsubform
    (syntax-rules ()
      [(_ spec desc ...)
       (make-blockquote "leftindent" (list (specsubform spec desc ...)))]))
  (define-syntax specspecsubform/subs
    (syntax-rules ()
      [(_ spec subs desc ...)
       (make-blockquote "leftindent" (list (specsubform/subs spec subs desc ...)))]))
  (define-syntax specform
    (syntax-rules ()
      [(_ #:literals (lit ...) spec desc ...)
       (*specsubform 'spec #t '(lit ...) (lambda () (schemeblock0/form spec)) null null (lambda () (list desc ...)))]
      [(_ spec desc ...)
       (*specsubform 'spec #t null (lambda () (schemeblock0/form spec)) null null (lambda () (list desc ...)))]))
  (define-syntax specform/subs
    (syntax-rules ()
      [(_ #:literals (lit ...) spec ([non-term-id non-term-form ...] ...) desc ...)
       (*specsubform 'spec #t 
                     '(lit ...)
                     (lambda () (schemeblock0/form spec)) 
                     '((non-term-id non-term-form ...) ...)
                     (list (list (lambda () (scheme non-term-id))
                                 (lambda () (schemeblock0/form non-term-form))
                                 ...)
                           ...)
                     (lambda () (list desc ...)))]
      [(_ spec ([non-term-id non-term-form ...] ...) desc ...)
       (specform/subs #:literals () spec ([non-term-id non-term-form ...] ...) desc ...)]))
  (define-syntax specsubform/inline
    (syntax-rules ()
      [(_ spec desc ...)
       (*specsubform 'spec #f null #f null null (lambda () (list desc ...)))]))
  (define-syntax defthing
    (syntax-rules ()
      [(_ id result desc ...)
       (*defthing (list (quote-syntax/loc id)) (list 'id) #f (list (schemeblock0 result)) 
                  (lambda () (list desc ...)))]))
  (define-syntax defthing*
    (syntax-rules ()
      [(_ ([id result] ...) desc ...)
       (*defthing (list (quote-syntax/loc id) ...) (list 'id ...) #f (list (schemeblock0 result) ...) 
                  (lambda () (list desc ...)))]))
  (define-syntax defparam
    (syntax-rules ()
      [(_ id arg contract desc ...)
       (defproc* ([(id) contract] [(id [arg contract]) void?]) desc ...)]))
  (define-syntax defparam*
    (syntax-rules ()
      [(_ id arg in-contract out-contract desc ...)
       (defproc* ([(id) out-contract] [(id [arg in-contract]) void?]) desc ...)]))
  (define-syntax defboolparam
    (syntax-rules ()
      [(_ id arg desc ...)
       (defproc* ([(id) boolean?] [(id [arg any/c]) void?]) desc ...)]))
  (define-syntax schemegrammar
    (syntax-rules ()
      [(_ #:literals (lit ...) id clause ...) (*schemegrammar '(lit ...) 
                                                              '(id clause ...)
                                                              (lambda () (list (list (scheme id) (schemeblock0/form clause) ...))))]
      [(_ id clause ...) (schemegrammar #:literals () id clause ...)]))
  (define-syntax schemegrammar*
    (syntax-rules ()
      [(_ #:literals (lit ...) [id clause ...] ...) (*schemegrammar '(lit ...) 
                                                                    '(id ... clause ... ...)
                                                                    (lambda () 
                                                                      (list
                                                                       (list (scheme id) (schemeblock0/form clause) ...) ...)))]
      [(_ [id clause ...] ...) (schemegrammar #:literals () [id clause ...] ...)]))
  (define-syntax var
    (syntax-rules ()
      [(_ id) (*var 'id)]))
  (define-syntax svar
    (syntax-rules ()
      [(_ id) (*var 'id)]))

  (define (into-blockquote s)
    (cond
     [(splice? s)
      (make-blockquote "leftindent" (flow-paragraphs (decode-flow (splice-run s))))]
     [else
      (make-blockquote "leftindent" (list s))]))

  (define (make-table-if-necessary style content)
    (if (= 1 (length content))
        (let ([paras (apply append (map flow-paragraphs (car content)))])
          (if (andmap paragraph? paras)
              (list (make-paragraph (apply append (map paragraph-content paras))))
              (list (make-table style content))))
        (list (make-table style content))))

  (define max-proto-width 65)

  (define (name-this-object type-sym)
    (to-element
     (string->symbol
      (regexp-replace
       #rx"(%|<%>|-mixin)$"
       (format "_a~a-~s" 
               (if (member
                    (string-ref (symbol->string type-sym) 0)
                    '(#\a #\e #\i #\o #\u))
                   "n"
                   "")
               type-sym)
       ""))))

  (define (annote-exporting-library e)
    (make-delayed-element
     (lambda (render p ri)
       (let ([from (resolve-get/tentative p ri '(exporting-libraries #f))])
         (if (and from
                  (pair? from))
             (list (make-hover-element
                    #f
                    (list e)
                    (string-append
                     "Provided from: "
                     (let loop ([from from])
                       (if (null? (cdr from))
                           (format "~s" (car from))
                           (format "~s, ~a"
                                   (car from)
                                   (loop (cdr from))))))))
             (list e))))
     (lambda () e)
     (lambda () e)))

  (define (get-exporting-libraries render p ri)
    (resolve-get/tentative p ri '(exporting-libraries #f)))

  (define (with-exporting-libraries proc)
    (make-delayed-index-desc
     (lambda (render part ri)
       (proc
        (or (get-exporting-libraries render part ri) null)))))

  (define-struct (box-splice splice) (var-list))

  (define (*deftogether boxes body-thunk)
    (make-splice
     (cons
      (make-table
       'boxed
       (map (lambda (box)
              (unless (and (box-splice? box)
                           (= 1 (length (splice-run box)))
                           (table? (car (splice-run box)))
                           (eq? 'boxed (table-style (car (splice-run box)))))
                (error 'deftogether "element is not a boxing splice containing a single table: ~e" box))
              (list (make-flow (list (make-table "together" (table-flowss (car (splice-run box))))))))
            boxes))
      (parameterize ([current-variable-list
                      (apply append (map box-splice-var-list boxes))])
        (body-thunk)))))

  (define-syntax-rule (deftogether (box ...) . body)
    (*deftogether (list box ...) (lambda () (list . body))))

  (define-struct arg (special? kw id optional? starts-optional? ends-optional? num-closers))
    
  (define (*defproc mode within-id
                    stx-ids prototypes arg-contractss arg-valss result-contracts content-thunk)
    (let ([spacer (hspace 1)]
          [has-optional? (lambda (arg)
                           (and (pair? arg)
                                ((length arg) . > . (if (keyword? (car arg))
                                                        3
                                                        2))))]
          [to-flow (lambda (e)
                     (make-flow (list (make-paragraph (list e)))))]
          [arg->elem (lambda (show-opt-start?)
                       (lambda (arg)
                         (let* ([e (cond
                                    [(not (arg-special? arg))
                                     (if (arg-kw arg)
                                         (if (eq? mode 'new)
                                             (make-element #f (list (schemeparenfont "[")
                                                                    (schemeidfont (keyword->string (arg-kw arg)))
                                                                    (hspace 1)
                                                                    (to-element (arg-id arg))
                                                                    (schemeparenfont "]")))
                                             (make-element #f (list (to-element (arg-kw arg))
                                                                    (hspace 1)
                                                                    (to-element (arg-id arg)))))
                                         (to-element (arg-id arg)))]
                                    [(eq? (arg-id arg) '...+)
                                     dots1]
                                    [(eq? (arg-id arg) '...)
                                     dots0]
                                    [else (arg-id arg)])]
                                [e (if (arg-ends-optional? arg)
                                       (make-element #f (list e "]"))
                                       e)]
                                [e (if (zero? (arg-num-closers arg))
                                       e
                                       (make-element #f
                                                     (list e
                                                           (schemeparenfont (make-string (arg-num-closers arg) #\))))))])
                           (if (and show-opt-start?
                                    (arg-starts-optional? arg))
                               (make-element #f (list "[" e))
                               e))))]
           [prototype-depth (lambda (p)
                              (let loop ([p (car p)])
                                (if (symbol? p)
                                    0
                                    (+ 1 (loop (car p))))))]
           [prototype-args (lambda (p)
                             (let ([parse-arg (lambda (v in-optional? depth next-optional? next-special?)
                                                (let* ([id (if (pair? v)
                                                               (if (keyword? (car v))
                                                                   (cadr v)
                                                                   (car v))
                                                               v)]
                                                       [kw (if (and (pair? v)
                                                                    (keyword? (car v)))
                                                               (car v)
                                                               #f)]
                                                       [default? (and (pair? v)
                                                                      (let ([p (if kw
                                                                                   (cdddr v)
                                                                                   (cddr v))])
                                                                        (pair? p)))])
                                                  (make-arg (symbol? v)
                                                            kw
                                                            id
                                                            default?
                                                            (and default?
                                                                 (not in-optional?))
                                                            (or (and (not default?)
                                                                     in-optional?) ; => must be special
                                                                (and default?
                                                                     (not next-optional?)
                                                                     (not next-special?)))
                                                            depth)))])
                               (let loop ([p p][last-depth 0])
                                 (append (if (symbol? (car p))
                                             null
                                             (loop (car p) (add1 last-depth)))
                                         (let loop ([p (cdr p)][in-optional? #f])
                                           (cond
                                            [(null? p) null]
                                            [(null? (cdr p))
                                             (list (parse-arg (car p) 
                                                              in-optional? 
                                                              last-depth
                                                              #f
                                                              #f))]
                                            [else
                                             (let ([a (parse-arg (car p) 
                                                                 in-optional? 
                                                                 0
                                                                 (let ([v (cadr p)])
                                                                   (and (pair? v)
                                                                        (not
                                                                         (null?
                                                                          ((if (keyword? (car v))
                                                                               cdddr
                                                                               cddr)
                                                                           v)))))
                                                                 (not (pair? (cadr p))))])
                                               (cons a
                                                     (loop (cdr p)
                                                           (and (arg-optional? a)
                                                                (not (arg-ends-optional? a))))))]))))))]
           [prototype-size (lambda (args first-combine next-combine)
                             (let loop ([s args][combine first-combine])
                               (if (null? s)
                                   0
                                   (combine
                                    (loop (cdr s) next-combine)
                                    (let ([a (car s)])
                                      (+ (arg-num-closers a)
                                         (cond
                                          [(arg-special? a)
                                           (string-length (symbol->string (arg-id a)))]
                                          [else
                                           (+ (if (arg-kw a)
                                                  (+ (if (eq? mode 'new) 2 0)
                                                     (string-length (keyword->string (arg-kw a)))
                                                     3
                                                     (string-length (symbol->string (arg-id a))))
                                                  (string-length (symbol->string (arg-id a)))))])))))))]
           [extract-id (lambda (p)
                           (let loop ([p p])
                             (if (symbol? (car p))
                                 (car p)
                                 (loop (car p)))))])
      (let* ([all-args (map prototype-args prototypes)]
             [var-list (filter values
                               (map (lambda (a)
                                      (and (not (arg-special? a))
                                           (arg-id a)))
                                    (apply append all-args)))])
        (parameterize ([current-variable-list var-list])
          (make-box-splice
           (cons
            (make-table
             'boxed
             (apply 
              append
              (map 
               (lambda (stx-id prototype args arg-contracts arg-vals result-contract first?)
                 (let*-values ([(tagged) (cond
                                          [(eq? mode 'new)
                                           (make-element #f
                                                         (list (scheme new)
                                                               (hspace 1)
                                                               (to-element within-id)))]
                                          [(eq? mode 'make)
                                           (make-element #f
                                                         (list (scheme make-object)
                                                               (hspace 1)
                                                               (to-element within-id)))]
                                          [(eq? mode 'send)
                                           (make-element #f
                                                         (list (scheme send)
                                                               (hspace 1)
                                                               (name-this-object (syntax-e within-id))
                                                               (hspace 1)
                                                               (if first?
                                                                   (let* ([mname (extract-id prototype)]
                                                                          [ctag (id-to-tag within-id)]
                                                                          [tag (method-tag ctag mname)]
                                                                          [content (list (*method mname within-id))])
                                                                     (if tag
                                                                         (make-toc-target-element
                                                                          #f
                                                                          (list (make-index-element #f
                                                                                                    content
                                                                                                    tag
                                                                                                    (list (symbol->string mname))
                                                                                                    content
                                                                                                    (with-exporting-libraries
                                                                                                     (lambda (libs)
                                                                                                       (make-method-index-desc 
                                                                                                        (syntax-e within-id)
                                                                                                        libs
                                                                                                        mname
                                                                                                        ctag)))))
                                                                          tag)
                                                                         (car content)))
                                                                   (*method (extract-id prototype) within-id))))]
                                          [else
                                           (if first?
                                               (let ([tag (id-to-tag stx-id)]
                                                     [content (list (definition-site (extract-id prototype) stx-id #f))])
                                                 (if tag
                                                     (make-toc-target-element
                                                      #f
                                                      (list (make-index-element #f
                                                                                content
                                                                                tag
                                                                                (list (symbol->string (extract-id prototype)))
                                                                                content
                                                                                (with-exporting-libraries
                                                                                 (lambda (libs)
                                                                                   (make-procedure-index-desc
                                                                                    (extract-id prototype)
                                                                                    libs)))))
                                                      tag)
                                                     (car content)))
                                               (annote-exporting-library
                                                (to-element (make-just-context (extract-id prototype)
                                                                               stx-id))))])]
                               [(flat-size) (+ (prototype-size args + +)
                                               (prototype-depth prototype)
                                               (element-width tagged))]
                               [(short?) (or (flat-size . < . 40)
                                             ((length args) . < . 2))]
                               [(res) (result-contract)]
                               [(result-next-line?) ((+ (if short? 
                                                            flat-size
                                                            (+ (prototype-size args max max)
                                                               (prototype-depth prototype)
                                                               (element-width tagged)))
                                                        (flow-element-width res))
                                                     . >= . (- max-proto-width 7))]
                               [(end) (list (to-flow spacer)
                                            (to-flow 'rarr)
                                            (to-flow spacer)
                                            (make-flow (list res)))])
                   (append
                    (list
                     (list (make-flow
                            (if short?
                                (make-table-if-necessary
                                 "prototype"
                                 (list
                                  (cons
                                   (to-flow
                                    (make-element
                                     #f
                                     (append
                                      (list
                                       (schemeparenfont (make-string (add1 (prototype-depth prototype)) #\())
                                       tagged)
                                      (if (null? args)
                                          (list
                                           (schemeparenfont (make-string (add1 (prototype-depth prototype)) #\))))
                                          (apply
                                           append
                                           (map
                                            (lambda (arg)
                                              (list
                                               spacer
                                               ((arg->elem #t) arg)))
                                            args)))
                                      (list (schemeparenfont ")")))))
                                   (if result-next-line?
                                       null
                                       end))))
                                (let ([not-end
                                       (if result-next-line?
                                           (list (to-flow spacer))
                                           (list (to-flow spacer)
                                                 (to-flow spacer)
                                                 (to-flow spacer)
                                                 (to-flow spacer)))])
                                  (list
                                   (make-table
                                    "prototype"
                                    (cons
                                     (list* (to-flow (make-element
                                                      #f
                                                      (list
                                                       (schemeparenfont (make-string (add1 (prototype-depth prototype)) #\())
                                                       tagged)))
                                            (cond
                                             [(arg-starts-optional? (car args))
                                              (to-flow (make-element #f (list spacer "[")))]
                                             [else
                                              (to-flow spacer)])
                                            (to-flow
                                             ((arg->elem #f) (car args)))
                                            not-end)
                                     (let loop ([args (cdr args)])
                                       (if (null? args)
                                           null
                                           (let ([dots-next? (or (and (pair? (cdr args))
                                                                      (arg-special? (cadr args))))])
                                             (cons (list* (to-flow spacer)
                                                          (if (arg-starts-optional? (car args))
                                                              (to-flow (make-element #f (list spacer "[")))
                                                              (to-flow spacer))
                                                          (let ([a ((arg->elem #f) (car args))]
                                                                [next (if dots-next?
                                                                          (make-element #f (list (hspace 1)
                                                                                                 ((arg->elem #f) (cadr args))))
                                                                          "")])
                                                            (to-flow 
                                                             (cond
                                                              [(null? ((if dots-next? cddr cdr) args))
                                                               (make-element 
                                                                #f 
                                                                (list a next (schemeparenfont ")")))]
                                                              [(equal? next "") a]
                                                              [else
                                                               (make-element #f (list a next))])))
                                                          (if (and (null? ((if dots-next? cddr cdr) args))
                                                                   (not result-next-line?))
                                                              end
                                                              not-end))
                                                   (loop ((if dots-next? cddr cdr) args))))))))))))))
                    (if result-next-line?
                        (list (list (make-flow (make-table-if-necessary
                                                "prototype" 
                                                (list end)))))
                        null)
                    (apply append
                           (map (lambda (arg arg-contract arg-val)
                                  (cond
                                   [(not (arg-special? arg))
                                    (let* ([arg-cont (arg-contract)]
                                           [base-len (+ 5 (string-length (symbol->string (arg-id arg)))
                                                        (flow-element-width arg-cont))]
                                           [arg-val (and arg-val (arg-val))]
                                           [def-len (if (arg-optional? arg)
                                                        (flow-element-width arg-val)
                                                        0)]
                                           [base-list
                                            (list
                                             (to-flow (hspace 2))
                                             (to-flow (to-element (arg-id arg)))
                                             (to-flow spacer)
                                             (to-flow ":")
                                             (to-flow spacer)
                                             (make-flow (list arg-cont)))])
                                      (list
                                       (list
                                        (make-flow
                                         (if (and (arg-optional? arg)
                                                  ((+ base-len 3 def-len) . >= . max-proto-width))
                                             (list
                                              (make-table
                                               "argcontract"
                                               (list
                                                base-list
                                                (list
                                                 (to-flow spacer)
                                                 (to-flow spacer)
                                                 (to-flow spacer)
                                                 (to-flow "=")
                                                 (to-flow spacer)
                                                 (make-flow (list arg-val))))))
                                             (make-table-if-necessary
                                              "argcontract"
                                              (list
                                               (append
                                                base-list
                                                (if (and (arg-optional? arg)
                                                         ((+ base-len 3 def-len) . < . max-proto-width))
                                                    (list (to-flow spacer)
                                                          (to-flow "=")
                                                          (to-flow spacer)
                                                          (make-flow (list arg-val)))
                                                    null)))))))))]
                                   [else null]))
                                args
                                arg-contracts
                                arg-vals)))))
               stx-ids
               prototypes
               all-args
               arg-contractss
               arg-valss
               result-contracts
               (let loop ([ps prototypes][accum null])
                 (cond
                  [(null? ps) null]
                  [(ormap (lambda (a) (eq? (extract-id (car ps)) a)) accum)
                   (cons #f (loop (cdr ps) accum))]
                  [else
                   (cons #t (loop (cdr ps)
                                  (cons (extract-id (car ps)) accum)))])))))
            (content-thunk))
           var-list)))))

  (define (make-target-element* inner-make-target-element stx-id content wrappers)
    (if (null? wrappers)
        content
        (make-target-element*
         make-target-element
         stx-id
         (let* ([name
                 (apply string-append
                        (map symbol->string (cdar wrappers)))]
                [tag 
                 (id-to-tag
                  (datum->syntax stx-id
                                 (string->symbol
                                  name)))])
           (if tag
               (inner-make-target-element
                #f
                (list
                 (make-index-element #f
                                     (list content)
                                     tag
                                     (list name)
                                     (list (schemeidfont (make-element "schemevaluelink" (list name))))
                                     (with-exporting-libraries
                                      (lambda (libs)
                                        (let ([name (string->symbol name)])
                                          (if (eq? 'info (caar wrappers))
                                              (make-struct-index-desc name libs)
                                              (make-procedure-index-desc name libs)))))))
                tag)
               content))
         (cdr wrappers))))

  (define (*defstruct stx-id name fields field-contracts immutable? transparent? content-thunk)
    (define spacer (hspace 1))
    (define to-flow (lambda (e) (make-flow (list (make-paragraph (list e))))))
    (define (field-name f) (if (pair? (car f))
                               (caar f)
                               (car f)))
    (define (field-view f) (if (pair? (car f))
                               (make-shaped-parens (car f) #\[)
                               (car f)))
    (make-box-splice
     (cons
      (make-table
       'boxed
       (cons
        (list (make-flow 
               (list
                (let* ([the-name
                        (let ([just-name
                               (make-target-element*
                                make-toc-target-element
                                stx-id
                                (annote-exporting-library
                                 (to-element (if (pair? name)
                                                 (make-just-context (car name) stx-id)
                                                 stx-id)))
                                (let ([name (if (pair? name)
                                                (car name)
                                                name)])
                                  (list* (list 'info name)
                                         (list 'type 'struct: name)
                                         (list 'predicate name '?)
                                         (list 'constructor 'make- name)
                                         (append
                                          (map (lambda (f)
                                                 (list 'accessor name '- (field-name f)))
                                               fields)
                                          (filter 
                                           values
                                           (map (lambda (f)
                                                  (if (or (not immutable?)
                                                          (and (pair? (car f))
                                                                (memq '#:mutable (car f))))
                                                      (list 'mutator 'set- name '- (field-name f) '!)
                                                      #f))
                                                fields))))))])
                          (if (pair? name)
                              (to-element (list just-name
                                                (make-just-context (cadr name) stx-id)))
                              just-name))]
                       [short-width (apply +
                                           (length fields)
                                           8
                                           (append
                                            (map (lambda (s)
                                                   (string-length (symbol->string s)))
                                                 (append (if (pair? name)
                                                             name
                                                             (list name))
                                                         (map field-name fields)))
                                            (map (lambda (f)
                                                   (if (pair? (car f))
                                                       (+ 3 2 (string-length (keyword->string (cadar f))))
                                                       0))
                                                 fields)))])
                  (if (and (short-width . < . max-proto-width)
                           (not immutable?)
                           (not transparent?))
                      (make-paragraph
                       (list
                        (to-element
                         `(,(schemeparenfont "struct")
                           ,the-name
                           ,(map field-view fields)))))
                      (make-table
                       #f
                       (append
                        (list
                         (list (to-flow (schemeparenfont "(struct"))
                               (to-flow spacer)
                               (to-flow the-name)
                               (if (or (null? fields)
                                       (short-width . < . max-proto-width))
                                   (to-flow spacer)
                                   (to-flow (make-element #f
                                                          (list spacer
                                                                (schemeparenfont "(")))))
                               (to-flow (if (or (null? fields)
                                                (short-width . < . max-proto-width))
                                            (make-element #f (list (to-element (map field-view fields))
                                                                   (schemeparenfont ")")))
                                            (to-element (field-view (car fields)))))))
                        (if (short-width . < . max-proto-width)
                            null
                            (let loop ([fields (if (null? fields) fields (cdr fields))])
                              (if (null? fields)
                                  null
                                  (cons (let ([fld (car fields)])
                                          (list (to-flow spacer)
                                                (to-flow spacer)
                                                (to-flow spacer)
                                                (to-flow spacer)
                                                (to-flow
                                                 (let ([e (to-element (field-view fld))])
                                                   (if (null? (cdr fields))
                                                       (make-element 
                                                        #f 
                                                        (list e 
                                                              (schemeparenfont 
                                                               (if (and immutable?
                                                                        (not transparent?))
                                                                   "))"
                                                                   ")"))))
                                                       e)))))
                                        (loop (cdr fields))))))
                        (cond
                         [(and (not immutable?) transparent?)
                          (list
                           (list (to-flow spacer)
                                 (to-flow spacer)
                                 (to-flow (to-element '#:mutable))
                                 'cont
                                 'cont)
                           (list (to-flow spacer)
                                 (to-flow spacer)
                                 (to-flow (make-element
                                           #f
                                           (list (to-element '#:inspector)
                                                 spacer
                                                 (to-element #f)
                                                 (schemeparenfont ")"))))
                                 'cont
                                 'cont))]
                         [(not immutable?)
                          (list
                           (list (to-flow spacer)
                                 (to-flow spacer)
                                 (to-flow (make-element
                                           #f
                                           (list (to-element '#:mutable)
                                                 (schemeparenfont ")"))))
                                 'cont
                                 'cont))]
                         [transparent?
                          (list
                           (list (to-flow spacer)
                                 (to-flow spacer)
                                 (to-flow (make-element
                                           #f
                                           (list (to-element '#:inspector)
                                                 spacer
                                                 (to-element #f)
                                                 (schemeparenfont ")"))))
                                 'cont
                                 'cont))]
                         [else null]))))))))
        (map (lambda (v field-contract)
               (cond
                [(pair? v)
                 (list
                  (make-flow
                   (make-table-if-necessary
                    "argcontract"
                    (list
                     (list (to-flow (hspace 2))
                           (to-flow (to-element (field-name v)))
                           (to-flow spacer)
                           (to-flow ":")
                           (to-flow spacer)
                           (make-flow (list (field-contract))))))))]
                [else null]))
             fields field-contracts)))
      (content-thunk))
     null))

  (define (*defthing stx-ids names form? result-contracts content-thunk)
    (define spacer (hspace 1))
    (make-box-splice
     (cons
      (make-table
       'boxed
       (map (lambda (stx-id name result-contract)
              (list
               (make-flow
                (make-table-if-necessary
                 "argcontract"
                 (list
                  (list (make-flow
                         (list
                          (make-paragraph
                           (list (let ([tag ((if form? id-to-form-tag id-to-tag) stx-id)]
                                       [content (list (definition-site name stx-id form?))])
                                   (if tag
                                       (make-toc-target-element
                                        #f
                                        (list (make-index-element #f
                                                                  content
                                                                  tag
                                                                  (list (symbol->string name))
                                                                  content
                                                                  (with-exporting-libraries
                                                                   (lambda (libs)
                                                                     (make-thing-index-desc name libs)))))
                                        tag)
                                       (car content)))
                                 spacer ":" spacer))))
                        (make-flow
                         (list
                          (if (flow-element? result-contract)
                              result-contract
                              (make-paragraph (list result-contract)))))))))))
            stx-ids names result-contracts))
      (content-thunk))
     null))

  (define (meta-symbol? s) (memq s '(... ...+ ?)))

  (define (*defforms kw-id lits forms form-procs subs sub-procs content-thunk)
    (let ([var-list
           (apply 
            append
            (map (lambda (form)
                   (let loop ([form (cons (if kw-id 
                                              (if (pair? form)
                                                  (cdr form) 
                                                  null)
                                              form)
                                          subs)])
                     (cond
                      [(symbol? form) (if (or (meta-symbol? form)
                                              (memq form lits))
                                          null
                                          (list form))]
                      [(pair? form) (append (loop (car form))
                                            (loop (cdr form)))]
                      [else null])))
                 forms))])
      (parameterize ([current-variable-list var-list]
                     [current-meta-list '(... ...+)])
        (make-box-splice
         (cons
          (make-table
           'boxed
           (append
            (map (lambda (form form-proc)
                   (list
                    (make-flow 
                     (list
                      ((or form-proc
                           (lambda (x)
                             (make-paragraph
                              (list
                               (to-element
                                `(,x . ,(cdr form)))))))
                       (and kw-id
                            (eq? form (car forms))
                            (let ([tag (id-to-tag kw-id)]
                                  [stag (id-to-form-tag kw-id)]
                                  [content (list (definition-site (if (pair? form)
                                                                      (car form) 
                                                                      form)
                                                   kw-id
                                                   #t))])
                              (if tag
                                  (make-target-element
                                   #f
                                   (list
                                    (make-toc-target-element
                                     #f
                                     (if kw-id
                                         (list (make-index-element #f
                                                                   content
                                                                   tag
                                                                   (list (symbol->string (syntax-e kw-id)))
                                                                   content
                                                                   (with-exporting-libraries
                                                                    (lambda (libs)
                                                                      (make-form-index-desc (syntax-e kw-id) libs)))))
                                         content)
                                     stag))
                                   tag)
                                  (car content)))))))))
                 forms form-procs)
            (if (null? sub-procs)
                null
                (list (list (make-flow (list (make-paragraph (list (tt 'nbsp))))))
                      (list (make-flow (list (let ([l (map (lambda (sub)
                                                             (map (lambda (f) (f)) sub))
                                                           sub-procs)])
                                               (*schemerawgrammars
                                                "specgrammar"
                                                (map car l)
                                                (map cdr l))))))))))
          (content-thunk))
         var-list))))
  
  (define (*specsubform form has-kw? lits form-thunk subs sub-procs content-thunk)
    (parameterize ([current-variable-list
                    (append (let loop ([form (cons (if has-kw? (cdr form) form)
                                                   subs)])
                              (cond
                               [(symbol? form) (if (or (meta-symbol? form)
                                                       (memq form lits))
                                                   null
                                                   (list form))]
                               [(pair? form) (append (loop (car form))
                                                     (loop (cdr form)))]
                               [else null]))
                            (current-variable-list))]
                   [current-meta-list '(... ...+)])
      (make-blockquote
       "leftindent"
       (cons
        (make-table
         'boxed
         (cons
          (list
           (make-flow
            (list
             (if form-thunk
                 (form-thunk)
                 (make-paragraph (list (to-element form)))))))
          (if (null? sub-procs)
              null
              (list (list (make-flow (list (make-paragraph (list (tt 'nbsp))))))
                    (list (make-flow (list (let ([l (map (lambda (sub)
                                                           (map (lambda (f) (f)) sub))
                                                         sub-procs)])
                                             (*schemerawgrammars
                                              "specgrammar"
                                              (map car l)
                                              (map cdr l))))))))))
        (flow-paragraphs (decode-flow (content-thunk)))))))

  (define (*schemerawgrammars style nonterms clauseses)
    (make-table
     `((valignment baseline baseline baseline baseline baseline)
       (alignment right left center left left)
       (style ,style))
     (let ([empty-line (make-flow (list (make-paragraph (list (tt 'nbsp)))))]
           [to-flow (lambda (i) (make-flow (list (make-paragraph (list i)))))])
       (cdr
        (apply append
               (map
                (lambda (nonterm clauses)
                  (list*
                   (list empty-line empty-line empty-line empty-line empty-line)
                   (list (to-flow nonterm)
                         empty-line
                         (to-flow "=")
                         empty-line
                         (make-flow (list (car clauses))))
                   (map (lambda (clause)
                          (list empty-line
                                empty-line
                                (to-flow "|")
                                empty-line
                                (make-flow (list clause))))
                        (cdr clauses))))
                nonterms clauseses))))))

  (define (*schemerawgrammar style nonterm clause1 . clauses)
    (*schemerawgrammars style (list nonterm) (list (cons clause1 clauses))))

  (define (*schemegrammar lits s-expr clauseses-thunk)
    (parameterize ([current-variable-list
                    (let loop ([form s-expr])
                      (cond
                       [(symbol? form) (if (memq form lits)
                                           null
                                           (list form))]
                       [(pair? form) (append (loop (car form))
                                             (loop (cdr form)))]
                       [else null]))])
      (let ([l (clauseses-thunk)])
        (*schemerawgrammars #f 
                            (map (lambda (x)
                                   (make-element #f
                                                 (list (hspace 2)
                                                       (car x))))
                                 l)
                            (map cdr l)))))

  (define (*var id)
    (to-element (*var-sym id)))

  (define (*var-sym id)
    (string->symbol (format "_~a" id)))

  ;; ----------------------------------------

  (provide centerline)
  (define (centerline . s)
    (make-table 'centered (list (list (make-flow (list (decode-paragraph s)))))))

  (provide commandline)
  (define (commandline . s)
    (make-paragraph (list (hspace 2) (apply tt s))))
  
  (define (elemtag t . body)
    (make-target-element #f (decode-content body) `(elem ,t)))
  (define (elemref t . body)
    (make-link-element #f (decode-content body) `(elem ,t)))
  (provide elemtag elemref)

  (define (doc-prefix doc s)
    (if doc
        (format "~a:~a" 
                (module-path-prefix->string doc)
                s)
        s))

  (define (secref s #:underline? [u? #t] #:doc [doc #f])
    (make-link-element (if u? #f "plainlink") null `(part ,(doc-prefix doc s))))
  (define (seclink tag #:underline? [u? #t] #:doc [doc #f] . s)
    (make-link-element (if u? #f "plainlink") (decode-content s) `(part ,(doc-prefix doc tag))))
  (define (*schemelink stx-id id . s)
    (make-link-element #f (decode-content s) (or (register-scheme-definition stx-id)
                                                 (format "--UNDEFINED:~a--" (syntax-e stx-id)))))
  (define-syntax schemelink
    (syntax-rules ()
      [(_ id . content) (*schemelink (quote-syntax id) 'id . content)]))
  (provide secref seclink schemelink)

  (define (pidefterm . s)
    (let ([c (apply defterm s)])
      (index (string-append (content->string (element-content c)) "s") 
             c)))
  (provide pidefterm)


  (define hash-lang (make-link-element
                     "schememodlink"
                     (list (schememodfont "#lang"))
                     `(part ,(doc-prefix '(lib "scribblings/guide/guide.scrbl")
                                         "hash-lang"))))
  
  ;; ----------------------------------------

  (provide math)
  (define (math . s)
    (let ([c (decode-content s)])
      (make-element #f (apply append
                              (map (lambda (i)
                                     (let loop ([i i])
                                       (cond
                                        [(string? i)
                                         (cond
                                          [(regexp-match #rx"^(.*)([()0-9])(.*)$" i)
                                           => (lambda (m)
                                                (append (loop (cadr m))
                                                        (list (caddr m))
                                                        (loop (cadddr m))))]
                                          [else
                                           (list (make-element 'italic (list i)))])]
                                        [(eq? i 'rsquo) (list 'prime)]
                                        [else (list i)])))
                                   c)))))

  ;; ----------------------------------------

  (provide cite
           bib-entry
           (rename-out [a-bib-entry? bib-entry?])
           bibliography)

  (define (cite key . keys)
    (make-element
     #f
     (list "["
           (let loop ([keys (cons key keys)])
             (if (null? (cdr keys))
                 (make-link-element
                  #f
                  (list (car keys))
                  `(cite ,(car keys)))
                 (make-element
                  #f
                  (list (loop (list (car keys)))
                        ", "
                        (loop (cdr keys))))))
           "]")))

  (define-struct a-bib-entry (key val))

  (define (bib-entry #:key key 
                     #:title title 
                     #:author [author #f] 
                     #:location [location #f]
                     #:date [date #f]
                     #:url [url #f])
    (make-a-bib-entry
     key
     (make-element
      #f
      (append
       (if author
           (list author
                 ", ")
           null)
       (list 'ldquo
             title
             (if location
                 "," 
                 ".")
             'rdquo)
       (if location
           (list " "
                 location
                 (if date 
                     ","
                     "."))
           null)
       (if date
           (list " "
                 date
                 ".")
           null)
       (if url
           (list " "
                 (link url (tt url)))
           null)))))

  (define (bibliography #:tag [tag "doc-bibliography"] . citations)
    (make-unnumbered-part
     #f
     (list `(part ,tag))
     (list "Bibliography")
     '()
     null
     (make-flow
      (list
       (make-table
        "bibliography"
        (map (lambda (c)
               (let ([key (a-bib-entry-key c)]
                     [val (a-bib-entry-val c)])
                 (list
                  (make-flow
                   (list
                    (make-paragraph
                     (list
                      (make-target-element 
                       #f
                       (list "[" key "]")
                       `(cite ,key))))))
                  (make-flow (list (make-paragraph (list (hspace 1)))))
                  (make-flow (list (make-paragraph (list val)))))))
             citations))))
     null))

  ;; ----------------------------------------

  (provide defclass
           defclass/title
           definterface
           definterface/title
           defconstructor
           defconstructor/make
           defconstructor*/make
           defconstructor/auto-super
           defmethod
           defmethod*
           methspec
           methimpl
           this-obj)

  (define-syntax-parameter current-class #f)

  (define-struct decl (name super intfs mk-head body))
  (define-struct constructor (def))
  (define-struct meth (name mode desc def))
  (define-struct spec (def))
  (define-struct impl (def))

  (define-serializable-struct cls/intf (name-element super intfs methods))

  (define (make-inherited-table r d ri decl)
    (let* ([start (let ([key (register-scheme-definition (decl-name decl))])
                    (list (cons key (lookup-cls/intf d ri key))))]
           [supers (cdr
                    (let loop ([supers start][accum null])
                      (cond
                       [(null? supers) (reverse accum)]
                       [(memq (car supers) accum)
                        (loop (cdr supers) accum)]
                       [else
                        (let ([super (car supers)])
                          (loop (append (map (lambda (i)
                                               (cons i (lookup-cls/intf d ri i)))
                                             (reverse (cls/intf-intfs (cdr super))))
                                        (let ([s (cls/intf-super (cdr super))])
                                          (if s
                                              (list (cons s (lookup-cls/intf d ri s)))
                                              null))
                                        (cdr supers))
                                (cons super accum)))])))]
           [ht (let ([ht (make-hash-table)])
                 (for-each (lambda (i)
                             (when (meth? i) 
                               (hash-table-put! ht (meth-name i) #t)))
                           (decl-body decl))
                 ht)]
           [inh (apply
                 append
                 (map (lambda (super)
                        (let ([inh (filter
                                    values
                                    (map
                                     (lambda (k)
                                       (if (hash-table-get ht k #f)
                                           #f
                                           (begin
                                             (hash-table-put! ht k #t)
                                             (cons (symbol->string k)
                                                   (**method k (car super))))))
                                     (cls/intf-methods (cdr super))))])
                          (if (null? inh)
                              null
                              (cons
                               (make-element #f (list (make-element "inheritedlbl" '("from "))
                                                      (cls/intf-name-element (cdr super))))
                               (map cdr (sort inh
                                              (lambda (a b)
                                                (string<? (car a) (car b)))))))))
                      supers))])
      (if (null? inh)
          (make-auxiliary-table "inherited" null)
          (make-auxiliary-table
           "inherited"
           (map (lambda (i)
                  (list (make-flow (list (make-paragraph (list i))))))
                (cons (make-element "inheritedlbl" '("Inherited methods:")) inh))))))

  (define (make-decl-collect decl)
    (make-part-collect-decl
     (make-collect-element
      #f null
      (lambda (ci)
        (let ([tag (register-scheme-definition (decl-name decl))])
          (collect-put! ci 
                        `(cls/intf ,tag)
                        (make-cls/intf
                         (make-element
                          "schemesymbol"
                          (list (make-link-element
                                 "schemevaluelink"
                                 (list (symbol->string (syntax-e (decl-name decl))))
                                 tag)))
                         (and (decl-super decl)
                              (not (free-label-identifier=? (quote-syntax object%)
                                                            (decl-super decl)))
                              (register-scheme-definition (decl-super decl)))
                         (map register-scheme-definition (decl-intfs decl))
                         (map (lambda (m)
                                (meth-name m))
                              (filter meth? (decl-body decl))))))))))

  (define (build-body decl body)
    (append
     (map (lambda (i)
            (cond
             [(constructor? i) ((constructor-def i))]
             [(meth? i)
              ((meth-def i) (meth-desc i))]
             [else i]))
          body)
     (list
      (make-delayed-flow-element
       (lambda (r d ri)
         (make-inherited-table r d ri decl))))))

  (define (*include-class/title decl)
    (make-splice
     (list* (title #:style 'hidden (to-element (decl-name decl)))
            (make-decl-collect decl)
            (build-body decl
                        (append
                         ((decl-mk-head decl) #t)
                         (decl-body decl))))))

  (define (*include-class decl)
    (make-splice
     (cons
      (make-decl-collect decl)
      (append
       ((decl-mk-head decl) #f)
       (list
        (make-blockquote 
         "leftindent"
         (flow-paragraphs
          (decode-flow
           (build-body decl (decl-body decl))))))))))

  (define (*class-doc stx-id super intfs whole-page? make-index-desc)
    (let ([spacer (hspace 1)])
      (make-table
       'boxed
       (append
        (list
         (list (make-flow 
                (list
                 (make-paragraph
                  (list (let ([tag (id-to-tag stx-id)]
                              [content (list (annote-exporting-library (to-element stx-id)))])
                          (if tag
                              ((if whole-page? 
                                   make-page-target-element
                                   make-toc-target-element)
                               #f
                               (list (make-index-element #f
                                                         content
                                                         tag
                                                         (list (symbol->string (syntax-e stx-id)))
                                                         content
                                                         (with-exporting-libraries
                                                          (lambda (libs)
                                                            (make-index-desc (syntax-e stx-id) libs)))))
                               tag)
                              (car content)))
                        spacer ":" spacer
                        (if super
                            (scheme class?)
                            (scheme interface?))))))))
        (if super
            (list
             (list (make-flow
                    (list
                     (t (hspace 2) "superclass:" spacer (to-element super))))))
            null)
        (if (null? intfs)
            null
            (list
             (list
              (make-flow
               (list
                (make-table #f
                            (cons
                             (list (make-flow (list (make-paragraph (list (hspace 2) 
                                                                          (if super
                                                                              "implements:" 
                                                                              "extends:")
                                                                          spacer))))
                                   (make-flow (list (make-paragraph (list (to-element (car intfs)))))))
                             (map (lambda (i)
                                    (list (make-flow (list (make-paragraph (list spacer))))
                                          (make-flow (list (make-paragraph (list (to-element i)))))))
                                  (cdr intfs)))))))))))))

  (define-syntax *defclass
    (syntax-rules ()
      [(_ *include-class name super (intf ...) body ...)
       (*include-class
        (syntax-parameterize ([current-class (quote-syntax name)])
          (make-decl (quote-syntax/loc name)
                     (quote-syntax/loc super)
                     (list (quote-syntax/loc intf) ...)
                     (lambda (whole-page?)
                       (list
                        (*class-doc (quote-syntax/loc name)
                                    (quote-syntax super)
                                    (list (quote-syntax intf) ...)
                                    whole-page?
                                    make-class-index-desc)))
                     (list body ...))))]))

  (define-syntax defclass
    (syntax-rules ()
      [(_ name super (intf ...) body ...)
       (*defclass *include-class name super (intf ...) body ...)]))

  (define-syntax defclass/title
    (syntax-rules ()
      [(_ name super (intf ...) body ...)
       (*defclass *include-class/title name super (intf ...) body ...)]))

  (define-syntax *definterface
    (syntax-rules ()
      [(_ *include-class name (intf ...) body ...)
       (*include-class
        (syntax-parameterize ([current-class (quote-syntax name)])
          (make-decl (quote-syntax/loc name)
                     #f
                     (list (quote-syntax/loc intf) ...)
                     (lambda (whole-page?)
                       (list
                        (*class-doc (quote-syntax/loc name)
                                    #f
                                    (list (quote-syntax intf) ...)
                                    whole-page?
                                    make-interface-index-desc)))
                     (list body ...))))]))
  
  (define-syntax definterface
    (syntax-rules ()
      [(_ name (intf ...) body ...)
       (*definterface *include-class name (intf ...) body ...)]))

  (define-syntax definterface/title
    (syntax-rules ()
      [(_ name (intf ...) body ...)
       (*definterface *include-class/title name (intf ...) body ...)]))

  (define-syntax (defconstructor*/* stx)
    (syntax-case stx ()
      [(_ mode ((arg ...) ...) desc ...)
       (let ([n (syntax-parameter-value #'current-class)])
         (with-syntax ([name n]
                       [result (datum->syntax #f
                                              (list
                                               (datum->syntax #'is-a?/c
                                                              'is-a?/c
                                                              (list 'src 1 1 2 1))
                                               (datum->syntax n
                                                              (syntax-e n)
                                                              (list 'src 1 3 4 1)))
                                              (list 'src 1 0 1 5))]
                       [(((kw ...) ...) ...) (map (lambda (ids)
                                                    (map (lambda (arg)
                                                           (if (and (pair? (syntax-e arg))
                                                                    (eq? (syntax-e #'mode) 'new))
                                                               (list (string->keyword (symbol->string 
                                                                                       (syntax-e 
                                                                                        (car (syntax-e arg))))))
                                                               null))
                                                         (syntax->list ids)))
                                                  (syntax->list #'((arg ...) ...)))])
           #'(make-constructor (lambda ()
                                 (defproc* #:mode mode #:within name [[(make [kw ... . arg] ...) result] ...]
                                   desc ...)))))]))

  (define-syntax (defconstructor stx)
    (syntax-case stx ()
      [(_ ([id . arg-rest] ...) desc ...)
       #'(defconstructor*/* new (([id . arg-rest] ...)) desc ...)]))

  (define-syntax (defconstructor/make stx)
    (syntax-case stx ()
      [(_ ([id . arg-rest] ...) desc ...)
       #'(defconstructor*/* make (([id . arg-rest] ...)) desc ...)]))

  (define-syntax (defconstructor*/make stx)
    (syntax-case stx ()
      [(_ (([id . arg-rest] ...) ...) desc ...)
       #'(defconstructor*/* make (([id . arg-rest] ...) ...) desc ...)]))

  (define-syntax (defconstructor/auto-super stx)
    (syntax-case stx ()
      [(_ ([id . arg-rest] ...) desc ...)
       #'(defconstructor*/* new (([id . arg-rest] ... _...superclass-args...)) desc ...)]))

  (define-syntax (defmethod* stx)
    (syntax-case stx ()
      [(_ #:mode mode ([(name arg ...) result-type] ...) desc ...)
       (with-syntax ([cname (syntax-parameter-value #'current-class)]
                     [name1 (car (syntax->list #'(name ...)))])
         (with-syntax ([(extra ...) (case (syntax-e #'mode)
                                      [(pubment)
                                       #'((t "Refine this method with " (scheme augment) "."))]
                                      [(override extend augment)
                                       #'((t (case (syntax-e #'mode)
                                               [(override) "Overrides "]
                                               [(extend) "Extends "]
                                               [(augment) "Augments "])
                                             (*xmethod/super (quote-syntax/loc cname) 'name1) "."))]
                                      [else
                                       null])])
           #'(make-meth 'name1
                        'mode
                        (lambda () (make-splice (apply
                                                 append
                                                 (map (lambda (f)
                                                        (cond
                                                         [(impl? f) ((impl-def f))]
                                                         [(spec? f) ((spec-def f))]
                                                         [else (list f)]))
                                                      (list extra ... desc ...)))))
                        (lambda (desc-splice)
                          (defproc* #:mode send #:within cname ([(name arg ...) result-type] ...)
                            (desc-splice))))))]
      [(_ ([(name arg ...) result-type] ...) desc ...)
       #'(defmethod* #:mode public ([(name arg ...) result-type] ...) desc ...)]))

  (define-syntax defmethod
    (syntax-rules ()
      [(_ #:mode mode (name arg ...) result-type desc ...)
       (defmethod* #:mode mode ([(name arg ...) result-type]) desc ...)]
      [(_ (name arg ...) result-type desc ...)
       (defmethod #:mode public (name arg ...) result-type desc ...)]))
  
  (define-syntax methimpl
    (syntax-rules ()
      [(_ body ...) (make-impl (lambda () (list (italic "Default implementation:") body ...)))]))
  
  (define-syntax methspec
    (syntax-rules ()
      [(_ body ...) (make-spec (lambda () (list (italic "Specification:") body ...)))]))

  (define (*this-obj cname)
    (name-this-object cname))

  (define-syntax (this-obj stx)
    (syntax-case stx ()
      [(_) 
       (with-syntax ([cname (syntax-parameter-value #'current-class)])
         #'(*this-obj 'cname))]))

  (define (*xmethod/super cname name)
    (let ([get
           (lambda (d ri key)
             (let ([v (lookup-cls/intf d ri key)])
               (if v
                   (cons (cls/intf-super v)
                         (cls/intf-intfs v))
                   null)))]
          [ctag (id-to-tag cname)])
      (make-delayed-element
       (lambda (r d ri)
         (let loop ([search (get d ri ctag)])
           (cond
            [(null? search)
             (make-element #f "<method not found>")]
            [(not (car search))
             (loop (cdr search))]
            [else
             (let ([v (lookup-cls/intf d ri (car search))])
               (if v
                   (if (member name (cls/intf-methods v))
                       (list
                        (make-element #f
                                      (list (**method name (car search))
                                            " in " 
                                            (cls/intf-name-element v))))
                       (loop (append (cdr search) (get d ri (car search)))))
                   (loop (cdr search))))])))
       (lambda () (format "~a in ~a" (syntax-e cname) name))
       (lambda () (format "~a in ~a" (syntax-e cname) name)))))

  (define (lookup-cls/intf d ri name)
    (let ([v (resolve-get d ri `(cls/intf ,name))])
      (or v
          (make-cls/intf "unknown"
                         #f
                         null
                         null))))

  ;; ----------------------------------------

  (provide defsignature
           defsignature/splice
           signature-desc)

  (define-syntax defsignature
    (syntax-rules ()
      [(_ name (super ...) body ...)
       (*defsignature
        (quote-syntax name)
        (list (quote-syntax super) ...)
        (lambda ()
          (list body ...))
        #t)]))

  (define-syntax defsignature/splice
    (syntax-rules ()
      [(_ name (super ...) body ...)
       (*defsignature
        (quote-syntax name)
        (list (quote-syntax super) ...)
        (lambda ()
          (list body ...))
        #f)]))

  (define-struct sig-desc (in))
  (define (signature-desc . l)
    (make-sig-desc l))

  (define (*defsignature stx-id supers body-thunk indent?)
    (*defthing (list stx-id)
               (list (syntax-e stx-id))
               #t 
               (list (make-element #f '("signature")))
               (lambda ()
                 (let ([in (parameterize ([current-signature (make-sig
                                                              (id-to-form-tag stx-id))])
                             (body-thunk))])
                   (if indent?
                       (let-values ([(pre-body post-body)
                                     (let loop ([in in][pre-accum null])
                                       (cond
                                        [(null? in) (values (reverse pre-accum) null)]
                                        [(whitespace? (car in))
                                         (loop (cdr in) (cons (car in)
                                                              pre-accum))]
                                        [(sig-desc? (car in))
                                         (loop (cdr in) (append (reverse (sig-desc-in (car in)))
                                                                pre-accum))]
                                        [else
                                         (values (reverse pre-accum) in)]))])
                         (append
                          pre-body
                          (list
                           (make-blockquote 
                            "leftindent"
                            (flow-paragraphs
                             (decode-flow
                              post-body))))))
                       in)))))
  
  ;; ----------------------------------------

  )