From 4b6b80d7fcfb6a48e5414a306a22980ffd69d16e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 25 Apr 2009 13:46:54 +0000 Subject: [PATCH] fix Scribble rendering of links when tag-prefixed sub-sections appear in the same output anchor scope svn: r14608 original commit: 22864b594d11e027b7162fa82b30e207f91d7e1f --- collects/scribble/base-render.ss | 75 ++++++++++++++-------- collects/scribble/html-render.ss | 35 ++++++---- collects/scribble/latex-render.ss | 3 +- collects/scribble/struct.ss | 37 +++++++---- collects/scribblings/scribble/struct.scrbl | 2 +- 5 files changed, 100 insertions(+), 52 deletions(-) diff --git a/collects/scribble/base-render.ss b/collects/scribble/base-render.ss index d5fbe71c..72407734 100644 --- a/collects/scribble/base-render.ss +++ b/collects/scribble/base-render.ss @@ -109,6 +109,22 @@ (and (pair? p) (mobile-root? (car p)))) + ;; ---------------------------------------- + + (define/public (fresh-tag-collect-context? d ci) + #f) + (define/public (fresh-tag-resolve-context? d ri) + #f) + (define/public (fresh-tag-render-context? d ri) + #f) + + (define/private (extend-prefix d fresh?) + (cond + [fresh? null] + [(part-tag-prefix d) + (cons (part-tag-prefix d) (current-tag-prefixes))] + [else (current-tag-prefixes)])) + ;; ---------------------------------------- ;; marshal info @@ -174,26 +190,28 @@ (make-collected-info number parent (collect-info-ht p-ci))) - (when (part-title-content d) - (collect-content (part-title-content d) p-ci)) - (collect-part-tags d p-ci number) - (collect-content (part-to-collect d) p-ci) - (collect-flow (part-flow d) p-ci) - (let loop ([parts (part-parts d)] - [pos 1]) - (unless (null? parts) - (let ([s (car parts)]) - (collect-part s d p-ci - (cons (if (or (unnumbered-part? s) - (part-style? s 'unnumbered)) - #f - pos) - number)) - (loop (cdr parts) - (if (or (unnumbered-part? s) - (part-style? s 'unnumbered)) - pos - (add1 pos)))))) + (parameterize ([current-tag-prefixes + (extend-prefix d (fresh-tag-collect-context? d p-ci))]) + (when (part-title-content d) + (collect-content (part-title-content d) p-ci)) + (collect-part-tags d p-ci number) + (collect-content (part-to-collect d) p-ci) + (collect-flow (part-flow d) p-ci) + (let loop ([parts (part-parts d)] + [pos 1]) + (unless (null? parts) + (let ([s (car parts)]) + (collect-part s d p-ci + (cons (if (or (unnumbered-part? s) + (part-style? s 'unnumbered)) + #f + pos) + number)) + (loop (cdr parts) + (if (or (unnumbered-part? s) + (part-style? s 'unnumbered)) + pos + (add1 pos))))))) (let ([prefix (part-tag-prefix d)]) (for ([(k v) (collect-info-ht p-ci)]) (when (cadr k) @@ -284,11 +302,13 @@ (map (lambda (d) (resolve-part d ri)) ds)) (define/public (resolve-part d ri) - (when (part-title-content d) - (resolve-content (part-title-content d) d ri)) - (resolve-flow (part-flow d) d ri) - (for ([p (part-parts d)]) - (resolve-part p ri))) + (parameterize ([current-tag-prefixes + (extend-prefix d (fresh-tag-resolve-context? d ri))]) + (when (part-title-content d) + (resolve-content (part-title-content d) d ri)) + (resolve-flow (part-flow d) d ri) + (for ([p (part-parts d)]) + (resolve-part p ri)))) (define/public (resolve-content c d ri) (for ([i c]) @@ -373,6 +393,11 @@ (render-part d ri)) (define/public (render-part d ri) + (parameterize ([current-tag-prefixes + (extend-prefix d (fresh-tag-render-context? d ri))]) + (render-part-content d ri))) + + (define/public (render-part-content d ri) (list (when (part-title-content d) (render-content (part-title-content d) d ri)) diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss index 6be22c60..0cba736f 100644 --- a/collects/scribble/html-render.ss +++ b/collects/scribble/html-render.ss @@ -230,6 +230,7 @@ (class % (inherit render-content render-block + render-part collect-part install-file get-dest-directory @@ -295,6 +296,13 @@ (define/public (current-part-whole-page? d) (eq? d (current-top-part))) + (define/override (fresh-tag-collect-context? d ci) + (current-part-whole-page? d)) + (define/override (fresh-tag-resolve-context? d ri) + (part-whole-page? d ri)) + (define/override (fresh-tag-render-context? d ri) + (part-whole-page? d ri)) + (define/override (collect-part-tags d ci number) (for ([t (part-tags d)]) (let ([key (generate-tag t ci)]) @@ -303,7 +311,7 @@ (path->relative (current-output-file))) (or (part-title-content d) '("???")) (current-part-whole-page? d) - key))))) + (add-current-tag-prefix key)))))) (define/override (collect-target-element i ci) (let ([key (generate-tag (target-element-tag i) ci)]) @@ -320,7 +328,7 @@ (if (redirect-target-element? i) (make-literal-anchor (redirect-target-element-alt-anchor i)) - key))))) + (add-current-tag-prefix key)))))) (define (dest-path dest) (if (vector? dest) ; temporary @@ -556,10 +564,11 @@ ,(format "#~a" (anchor-name - (tag-key (if (part? p) - (car (part-tags p)) - (target-element-tag p)) - ri)))] + (add-current-tag-prefix + (tag-key (if (part? p) + (car (part-tags p)) + (target-element-tag p)) + ri))))] [class ,(cond [(part? p) "tocsubseclink"] @@ -795,13 +804,15 @@ d ri)))))) - (define/override (render-part d ri) + (define/override (render-part-content d ri) (let ([number (collected-info-number (part-collected-info d ri))]) `(,@(cond [(and (not (part-title-content d)) (null? number)) null] [(part-style? d 'hidden) (map (lambda (t) - `(a ((name ,(format "~a" (anchor-name (tag-key t ri))))))) + `(a ((name ,(format "~a" (anchor-name + (add-current-tag-prefix + (tag-key t ri)))))))) (part-tags d))] [else `((,(case (length number) [(0) 'h2] @@ -811,7 +822,8 @@ ,@(format-number number '((tt nbsp))) ,@(map (lambda (t) `(a ([name ,(format "~a" (anchor-name - (tag-key t ri)))]))) + (add-current-tag-prefix + (tag-key t ri))))]))) (part-tags d)) ,@(if (part-title-content d) (render-content (part-title-content d) d ri) @@ -875,8 +887,9 @@ ;; (commented) hack in scribble-common.js) `(noscript ,@(render-plain-element e part ri))))] [(target-element? e) - `((a ([name ,(format "~a" (anchor-name (tag-key (target-element-tag e) - ri)))])) + `((a ([name ,(format "~a" (anchor-name (add-current-tag-prefix + (tag-key (target-element-tag e) + ri))))])) ,@(render-plain-element e part ri))] [(and (link-element? e) (not (current-no-links))) (parameterize ([current-no-links #t]) diff --git a/collects/scribble/latex-render.ss b/collects/scribble/latex-render.ss index 35dc6155..490956d3 100644 --- a/collects/scribble/latex-render.ss +++ b/collects/scribble/latex-render.ss @@ -33,6 +33,7 @@ (inherit render-block render-content + render-part install-file format-number extract-part-style-files) @@ -69,7 +70,7 @@ (render-part d ri) (printf "\n\n\\postDoc\n\\end{document}\n"))) - (define/override (render-part d ri) + (define/override (render-part-content d ri) (let ([number (collected-info-number (part-collected-info d ri))]) (when (and (part-title-content d) (pair? number)) (when (part-style? d 'index) diff --git a/collects/scribble/struct.ss b/collects/scribble/struct.ss index f1cefbd1..1db2d654 100644 --- a/collects/scribble/struct.ss +++ b/collects/scribble/struct.ss @@ -376,26 +376,35 @@ (define deserialize-generated-tag (make-deserialize-info values values)) -(provide generate-tag tag-key) +(provide generate-tag tag-key + current-tag-prefixes + add-current-tag-prefix) (define (generate-tag tg ci) (if (generated-tag? (cadr tg)) - (let ([t (cadr tg)]) - (list (car tg) - (let ([tags (collect-info-tags ci)]) - (or (hash-ref tags t #f) - (let ([key (list* 'gentag - (hash-count tags) - (collect-info-gen-prefix ci))]) - (hash-set! tags t key) - key))))) - tg)) + (let ([t (cadr tg)]) + (list (car tg) + (let ([tags (collect-info-tags ci)]) + (or (hash-ref tags t #f) + (let ([key (list* 'gentag + (hash-count tags) + (collect-info-gen-prefix ci))]) + (hash-set! tags t key) + key))))) + tg)) (define (tag-key tg ri) (if (generated-tag? (cadr tg)) - (list (car tg) - (hash-ref (collect-info-tags (resolve-info-ci ri)) (cadr tg))) - tg)) + (list (car tg) + (hash-ref (collect-info-tags (resolve-info-ci ri)) (cadr tg))) + tg)) + +(define current-tag-prefixes (make-parameter null)) +(define (add-current-tag-prefix t) + (let ([l (current-tag-prefixes)]) + (if (null? l) + t + (cons (car t) (append l (cdr t)))))) ;; ---------------------------------------- diff --git a/collects/scribblings/scribble/struct.scrbl b/collects/scribblings/scribble/struct.scrbl index bc0a1566..6a147e32 100644 --- a/collects/scribblings/scribble/struct.scrbl +++ b/collects/scribblings/scribble/struct.scrbl @@ -189,7 +189,7 @@ added to a list value using @scheme[cons]; a prefix is not added to a outside the part, including the use of tags in the part's @scheme[tags] field. Typically, a document's main part has a tag prefix that applies to the whole document; references to sections and -defined terms within the document from other documents must include, +defined terms within the document from other documents must include the prefix, while references within the same document omit the prefix. Part prefixes can be used within a document as well, to help disambiguate references within the document.