From c2788702f80d56587261aae5a50d81c8e9f06e5b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 29 Jan 2008 21:27:34 +0000 Subject: [PATCH] add up-links to documents in the main doc dir; add plain-install makefile targets svn: r8466 original commit: 6ddbaba736ebee38145d5bff9c71363be6825df4 --- collects/scribble/html-render.ss | 264 ++++++++++++++++--------------- 1 file changed, 134 insertions(+), 130 deletions(-) diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss index 764e867c..a5313be7 100644 --- a/collects/scribble/html-render.ss +++ b/collects/scribble/html-render.ss @@ -39,6 +39,9 @@ p (main-collects-relative->path p)))) + (define (toc-part? d) + (part-style? d 'toc)) + ;; HTML anchors are case-insenstive. To make them ;; distinct, add a "." in front of capital letters. ;; Also clean up characters that give browers trouble @@ -76,7 +79,8 @@ format-number quiet-table-of-contents) - (init-field [css-path #f]) + (init-field [css-path #f] + [up-path #f]) (define/override (get-suffix) #".html") @@ -330,12 +334,137 @@ (div ((class "maincolumn")) (div ((class "main")) ,@(render-version d ri) - ,@(render-part d ri)))))]) + ,@(navigation d ri) + ,@(render-part d ri) + ,@(navigation d ri)))))]) (unless css-path (install-file scribble-css)) (printf "\n") (xml:write-xml/content (xml:xexpr->xml xpr))))) + (define/private (part-parent d ri) + (collected-info-parent (part-collected-info d ri))) + + (define/private (find-siblings d ri) + (let ([parent (collected-info-parent (part-collected-info d ri))]) + (let loop ([l (if parent + (part-parts parent) + (if (or (null? (part-parts d)) + (not (part-whole-page? (car (part-parts d)) ri))) + (list d) + (list d (car (part-parts d)))))] + [prev #f]) + (cond + [(eq? (car l) d) (values prev + (and (pair? (cdr l)) + (cadr l)))] + [else (loop (cdr l) (car l))])))) + + (define contents-content '("contents")) + (define index-content '("index")) + (define prev-content '(larr " prev")) + (define up-content '("up")) + (define next-content '("next " rarr)) + (define no-next-content next-content) + (define sep-element (make-element #f '(nbsp nbsp))) + + (define/public (derive-filename d) "bad.html") + + (define/private (navigation d ri) + (let ([parent (part-parent d ri)]) + (let*-values ([(prev next) (find-siblings d ri)] + [(prev) (if prev + (let loop ([prev prev]) + (if (and (toc-part? prev) + (pair? (part-parts prev))) + (loop (car (last-pair (part-parts prev)))) + prev)) + (and parent + (toc-part? parent) + parent))] + [(next) (cond + [(and (toc-part? d) + (pair? (part-parts d))) + (car (part-parts d))] + [(and (not next) + parent + (toc-part? parent)) + (let-values ([(prev next) + (find-siblings parent ri)]) + next)] + [else next])] + [(index) (let loop ([d d]) + (let ([p (part-parent d ri)]) + (if p + (loop p) + (let ([subs (part-parts d)]) + (and (pair? subs) + (let ([d (car (last-pair subs))]) + (and (part-style? d 'index) + d)))))))]) + (if (and (not prev) + (not next) + (not parent) + (not index) + (not up-path)) + null + `((div ([class "navleft"]) + ,@(render-content + (append + (list + (make-element + (if parent + (make-target-url "index.html" #f) + "nonavigation") + contents-content)) + (if index + (list + 'nbsp + (if (eq? d index) + (make-element + "nonavigation" + index-content) + (make-link-element + #f + index-content + (car (part-tags index))))) + null)) + d + ri)) + (div ([class "navright"]) + ,@(render-content + (list + (make-element + (if parent + (make-target-url (if prev + (derive-filename prev) + "index.html") + #f) + "nonavigation") + prev-content) + sep-element + (make-element + (if (or parent + up-path) + (make-target-url + (if parent + (if (toc-part? parent) + (derive-filename parent) + "index.html") + up-path) + #f) + "nonavigation") + up-content) + sep-element + (make-element + (if next + (make-target-url (derive-filename next) #f) + "nonavigation") + next-content)) + d + ri)) + (p nbsp)))))) + (define/override (render-one d ri fn) (render-one-part d ri fn null)) @@ -636,7 +765,7 @@ (current-subdirectory)) (super get-dest-directory))) - (define/private (derive-filename d) + (define/override (derive-filename d) (let ([fn (format "~a.html" (regexp-replace* "[^-a-zA-Z0-9_=]" (let ([s (cadr (car (part-tags d)))]) @@ -659,9 +788,6 @@ (define/override (current-part-whole-page? d) ((collecting-sub) . <= . 2)) - (define/private (toc-part? d) - (part-style? d 'toc)) - (define/override (collect-part d parent ci number) (let ([prev-sub (collecting-sub)]) (parameterize ([collecting-sub (if (toc-part? d) @@ -699,122 +825,9 @@ (define/override (toc-wrap p) (list p)) - (define contents-content '("contents")) - (define index-content '("index")) - (define prev-content '(larr " prev")) - (define up-content '("up")) - (define next-content '("next " rarr)) - (define no-next-content next-content) - (define sep-element (make-element #f '(nbsp nbsp))) - (inherit render-table render-paragraph) - (define/override (render-version r i) - null) - - (define/private (find-siblings d ri) - (let ([parent (collected-info-parent (part-collected-info d ri))]) - (let loop ([l (if parent - (part-parts parent) - (if (null? (part-parts d)) - (list d) - (list d (car (part-parts d)))))] - [prev #f]) - (cond - [(eq? (car l) d) (values prev - (and (pair? (cdr l)) - (cadr l)))] - [else (loop (cdr l) (car l))])))) - - (define/private (part-parent d ri) - (collected-info-parent (part-collected-info d ri))) - - (define/private (navigation d ri) - (let ([parent (part-parent d ri)]) - (let*-values ([(prev next) (find-siblings d ri)] - [(prev) (if prev - (let loop ([prev prev]) - (if (and (toc-part? prev) - (pair? (part-parts prev))) - (loop (car (last-pair (part-parts prev)))) - prev)) - (and parent - (toc-part? parent) - parent))] - [(next) (cond - [(and (toc-part? d) - (pair? (part-parts d))) - (car (part-parts d))] - [(and (not next) - parent - (toc-part? parent)) - (let-values ([(prev next) - (find-siblings parent ri)]) - next)] - [else next])] - [(index) (let loop ([d d]) - (let ([p (part-parent d ri)]) - (if p - (loop p) - (let ([subs (part-parts d)]) - (and (pair? subs) - (let ([d (car (last-pair subs))]) - (and (part-style? d 'index) - d)))))))]) - `((div ([class "navleft"]) - ,@(render-content - (append - (list - (make-element - (if parent - (make-target-url "index.html" #f) - "nonavigation") - contents-content)) - (if index - (list - 'nbsp - (if (eq? d index) - (make-element - "nonavigation" - index-content) - (make-link-element - #f - index-content - (car (part-tags index))))) - null)) - d - ri)) - (div ([class "navright"]) - ,@(render-content - (list - (make-element - (if parent - (make-target-url (if prev - (derive-filename prev) - "index.html") - #f) - "nonavigation") - prev-content) - sep-element - (make-element - (if parent - (make-target-url - (if (toc-part? parent) - (derive-filename parent) - "index.html") - #f) - "nonavigation") - up-content) - sep-element - (make-element - (if next - (make-target-url (derive-filename next) #f) - "nonavigation") - next-content)) - d - ri)))))) - (define/override (render-part d ri) (parameterize ([current-version (if (and (versioned-part? d) @@ -841,17 +854,8 @@ (let ([sep? (on-separate-page)]) (parameterize ([next-separate-page (toc-part? d)] [on-separate-page #f]) - (if sep? - ;; Navigation bars; - `(,@(super render-version d ri) - ,@(navigation d ri) - (p nbsp) - ,@(super render-part d ri) - (p nbsp) - ,@(navigation d ri) - (p nbsp)) - ;; Normal section render - (super render-part d ri))))])))) + ;; Normal section render + (super render-part d ri)))])))) (super-new)))