diff --git a/collects/scribble/base-render.ss b/collects/scribble/base-render.ss index 3236539d..50598f77 100644 --- a/collects/scribble/base-render.ss +++ b/collects/scribble/base-render.ss @@ -273,24 +273,32 @@ ;; ---------------------------------------- - (define/public (table-of-contents part ht) + (define/private (do-table-of-contents part ht delta quiet) (make-table #f (render-toc part - (sub1 (length (collected-info-number - (part-collected-info part)))) - #t))) + (+ delta + (length (collected-info-number + (part-collected-info part)))) + #t + quiet))) + + (define/public (table-of-contents part ht) + (do-table-of-contents part ht -1 not)) (define/public (local-table-of-contents part ht) (table-of-contents part ht)) - (define/private (render-toc part base-len skip?) + (define/public (quiet-table-of-contents part ht) + (do-table-of-contents part ht 1 (lambda (x) #t))) + + (define/private (render-toc part base-len skip? quiet) (let ([number (collected-info-number (part-collected-info part))]) (let ([subs - (if (not (and (styled-part? part) - (eq? 'quiet (styled-part-style part)) - (not (= base-len (sub1 (length number)))))) + (if (quiet (and (styled-part? part) + (eq? 'quiet (styled-part-style part)) + (not (= base-len (sub1 (length number)))))) (apply append - (map (lambda (p) (render-toc p base-len #f)) (part-parts part))) + (map (lambda (p) (render-toc p base-len #f quiet)) (part-parts part))) null)]) (if skip? subs diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss index 7ea13a56..cbe3c65a 100644 --- a/collects/scribble/html-render.ss +++ b/collects/scribble/html-render.ss @@ -32,7 +32,8 @@ get-dest-directory format-number strip-aux - lookup) + lookup + quiet-table-of-contents) (define/override (get-suffix) #".html") @@ -47,7 +48,11 @@ fns) ht)) - (define/public (part-whole-page? d) + (define/public (part-whole-page? p ht) + (let ([dest (lookup p ht `(part ,(part-tag p)))]) + (caddr dest))) + + (define/public (current-part-whole-page?) #f) (define/override (collect-part-tag d ht number) @@ -55,7 +60,7 @@ `(part ,(part-tag d)) (list (current-output-file) (part-title-content d) - (part-whole-page? d)))) + (current-part-whole-page?)))) (define/override (collect-target-element i ht) (hash-table-put! ht @@ -71,37 +76,117 @@ (if p (loop p d) (values d mine))))]) - `((div ((class "tocview")) - (div ((class "tocviewtitle")) - (a ((href "index.html") - (class "tocviewlink")) - ,@(render-content (part-title-content top) d ht))) - (div nbsp) - (table - ((class "tocviewlist") - (cellspacing "0")) - ,@(map (lambda (p) - `(tr - (td - ((align "right")) - ,@(format-number (collected-info-number (part-collected-info p)) - '((tt nbsp)))) - (td - (a ((href ,(let ([dest (lookup p ht `(part ,(part-tag p)))]) - (format "~a~a~a" - (from-root (car dest) - (get-dest-directory)) - (if (caddr dest) - "" - "#") - (if (caddr dest) - "" - `(part ,(part-tag p)))))) - (class ,(if (eq? p mine) - "tocviewselflink" - "tocviewlink"))) - ,@(render-content (part-title-content p) d ht))))) - (part-parts top))))))) + `((div ((class "tocset")) + (div ((class "tocview")) + (div ((class "tocviewtitle")) + (a ((href "index.html") + (class "tocviewlink")) + ,@(render-content (part-title-content top) d ht))) + (div nbsp) + (table + ((class "tocviewlist") + (cellspacing "0")) + ,@(map (lambda (p) + `(tr + (td + ((align "right")) + ,@(format-number (collected-info-number (part-collected-info p)) + '((tt nbsp)))) + (td + (a ((href ,(let ([dest (lookup p ht `(part ,(part-tag p)))]) + (format "~a~a~a" + (from-root (car dest) + (get-dest-directory)) + (if (caddr dest) + "" + "#") + (if (caddr dest) + "" + `(part ,(part-tag p)))))) + (class ,(if (eq? p mine) + "tocviewselflink" + "tocviewlink"))) + ,@(render-content (part-title-content p) d ht))))) + (part-parts top)))) + ,@(if (ormap (lambda (p) (part-whole-page? p ht)) (part-parts d)) + null + (let ([ps (cdr + (let flatten ([d d]) + (cons d + (apply + append + (letrec ([flow-targets + (lambda (flow) + (apply append (map flow-element-targets (flow-paragraphs flow))))] + [flow-element-targets + (lambda (e) + (cond + [(table? e) (table-targets e)] + [(paragraph? e) (para-targets e)] + [(itemization? e) + (apply append (map flow-targets (itemization-flows e)))] + [(blockquote? e) + (apply append (map flow-element-targets (blockquote-paragraphs e)))] + [(delayed-flow-element? e) + null]))] + [para-targets + (lambda (para) + (let loop ([c (paragraph-content para)]) + (cond + [(empty? c) null] + [else (let ([a (car c)]) + (cond + [(toc-target-element? a) + (cons a (loop (cdr c)))] + [(element? a) + (append (loop (element-content a)) + (loop (cdr c)))] + [(delayed-element? a) + (loop (cons (force-delayed-element a this d ht) + (cdr c)))] + [else + (loop (cdr c))]))])))] + [table-targets + (lambda (table) + (apply append + (map (lambda (flows) + (apply append (map (lambda (f) + (if (eq? f 'cont) + null + (flow-targets f))) + flows))) + (table-flowss table))))]) + (apply append (map flow-element-targets (flow-paragraphs (part-flow d))))) + (map flatten (part-parts d))))))]) + (if (null? ps) + null + `((div ((class "tocsub")) + (div ((class "tocsubtitle")) + "On this page:") + (table + ((class "tocsublist") + (cellspacing "0")) + ,@(map (lambda (p) + (parameterize ([current-no-links #t]) + `(tr + (td + ,@(if (part? p) + `((span ((class "tocsublinknumber")) + ,@(format-number (collected-info-number (part-collected-info p)) + '((tt nbsp))))) + '("")) + (a ((href ,(if (part? p) + (let ([dest (lookup p ht `(part ,(part-tag p)))]) + (format "#~a" + `(part ,(part-tag p)))) + (format "#~a" (target-element-tag p)))) + (class ,(if (part? p) + "tocsubseclink" + "tocsublink"))) + ,@(if (part? p) + (render-content (part-title-content p) d ht) + (render-content (element-content p) d ht))))))) + ps))))))))))) (define/public (render-one-part d ht fn number) (parameterize ([current-output-file fn]) @@ -356,7 +441,7 @@ (build-path fn "index.html")) fns))) - (define/override (part-whole-page? d) + (define/override (current-part-whole-page?) ((collecting-sub) . <= . 2)) (define/private (toc-part? d) diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss index aa6cbcd9..5c6be7d0 100644 --- a/collects/scribble/manual.ss +++ b/collects/scribble/manual.ss @@ -487,7 +487,7 @@ (loop (cdr a) (cons (car a) o-accum))))) (loop (cdr a) (cons (car a) r-accum))))] [(tagged) (if first? - (make-target-element + (make-toc-target-element #f (list (to-element (make-just-context (car prototype) stx-id))) @@ -661,12 +661,13 @@ (cons #t (map (lambda (x) #f) (cdr prototypes)))))) (content-thunk)))))) - (define (make-target-element* stx-id content wrappers) + (define (make-target-element* inner-make-target-element stx-id content wrappers) (if (null? wrappers) content (make-target-element* + make-target-element stx-id - (make-target-element + (inner-make-target-element #f (list content) (register-scheme-definition @@ -686,38 +687,42 @@ (cons (list (make-flow (list - (let* ([the-name - (make-target-element* - stx-id - (to-element (if (pair? name) - (map (lambda (x) - (make-just-context x stx-id)) - name) - stx-id)) - (let ([name (if (pair? name) - (car name) - name)]) - (list* (list name) - (list name '?) - (list 'make- name) - (append - (map (lambda (f) - (list name '- (car f))) - fields) - (if immutable? - null - (map (lambda (f) - (list 'set- name '- (car f) '!)) - fields))))))] - [short-width (apply + - (length fields) - 8 - (map (lambda (s) - (string-length (symbol->string s))) - (append (if (pair? name) - name - (list name)) - (map car fields))))]) + (let* ([the-name + (let ([just-name + (make-target-element* + make-toc-target-element + stx-id + (to-element (if (pair? name) + (make-just-context (car name) stx-id) + stx-id)) + (let ([name (if (pair? name) + (car name) + name)]) + (list* (list name) + (list name '?) + (list 'make- name) + (append + (map (lambda (f) + (list name '- (car f))) + fields) + (if immutable? + null + (map (lambda (f) + (list 'set- name '- (car 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 + (map (lambda (s) + (string-length (symbol->string s))) + (append (if (pair? name) + name + (list name)) + (map car fields))))]) (if (and (short-width . < . max-proto-width) (not immutable?) (not transparent?)) @@ -836,7 +841,7 @@ (list (make-flow (list (make-paragraph - (list (make-target-element + (list (make-toc-target-element #f (list (to-element (make-just-context name stx-id))) (register-scheme-definition stx-id)) @@ -885,7 +890,7 @@ . ,(cdr form))))))) (and kw-id (eq? form (car forms)) - (make-target-element + (make-toc-target-element #f (list (to-element (make-just-context (if (pair? form) (car form) diff --git a/collects/scribble/scribble.css b/collects/scribble/scribble.css index 76a9151e..2ebfec87 100644 --- a/collects/scribble/scribble.css +++ b/collects/scribble/scribble.css @@ -35,15 +35,24 @@ border: 0.5em solid #F5F5DC; } - .tocview { + .tocset { position: relative; float: left; width: 10em; margin-right: 2em; + } + + .tocview { text-align: left; background-color: #F5F5DC; } + .tocsub { + margin-top: 1em; + text-align: left; + background-color: #DCF5F5; + } + .tocviewtitle { font-size: 80%; font-weight: bold; @@ -63,6 +72,35 @@ text-decoration: none; } + .tocsublist { + margin: 0.2em 0.2em 0.2em 0.2em; + } + + .tocsublist td { + vertical-align: top; + padding-left: 1em; + text-indent: -1em; + } + + .tocsublinknumber { + font-size: 80%; + } + + .tocsublink { + text-decoration: none; + } + + .tocsubseclink { + font-size: 80%; + text-decoration: none; + } + + .tocsubtitle { + font-size: 80%; + font-style: italic; + margin: 0.2em 0.2em 0.2em 0.2em; + } + .leftindent { margin-left: 1em; margin-right: 0em; diff --git a/collects/scribble/struct.ss b/collects/scribble/struct.ss index 14ce4667..a2f51d2c 100644 --- a/collects/scribble/struct.ss +++ b/collects/scribble/struct.ss @@ -72,6 +72,7 @@ [element ([style any/c] [content list?])] [(target-element element) ([tag tag?])] + [(toc-target-element target-element) ()] [(link-element element) ([tag tag?])] [(index-element element) ([tag tag?] [plain-seq (listof string?)]