suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

fix next-links that climb up more than one level

Browse Source 
svn: r10178

original commit: a679c89cb619c9c78f4c3d75d6a220414b042a62
This commit is contained in:
Eli Barzilay 2008-06-06 15:53:42 +00:00
parent 5c1f7ccbbc
commit 316a99fb56
1 changed files with 87 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

178
collects/scribble/html-render.ss
View File

@ -557,102 +557,98 @@
(define prev-content '(larr " prev")) (define prev-content '(larr " prev"))
(define up-content '("up")) (define up-content '("up"))
(define next-content '("next " rarr)) (define next-content '("next " rarr))
(define no-next-content next-content)
(define sep-element (make-element #f '(nbsp nbsp))) (define sep-element (make-element #f '(nbsp nbsp)))
(define/public (derive-filename d) "bad.html") (define/public (derive-filename d) "bad.html")
(define/private (navigation d ri pre-space?) (define/private (navigation d ri pre-space?)
(let*-values ([(parent) (part-parent d ri)] (define parent (part-parent d ri))
[(prev next) (find-siblings d ri)] (define-values (prev0 next0) (find-siblings d ri))
[(prev) (if prev (define prev
(let loop ([prev prev]) (if prev0
(if (and (toc-part? prev) (let loop ([p prev0])
(pair? (part-parts prev))) (if (and (toc-part? p) (pair? (part-parts p)))
(loop (car (last-pair (part-parts prev)))) (loop (last (part-parts p)))
prev)) p))
(and parent (toc-part? parent) parent))] (and parent (toc-part? parent) parent)))
[(next) (cond [(and (toc-part? d) (define next
(pair? (part-parts d))) (cond [(and (toc-part? d) (pair? (part-parts d))) (car (part-parts d))]
(car (part-parts d))] [(not next0)
[(and (not next) parent (toc-part? parent)) (let loop ([p parent])
(let-values ([(prev next) (and p (toc-part? p)
(find-siblings parent ri)]) (let-values ([(prev next) (find-siblings p ri)])
next)] (or next (loop (part-parent p ri))))))]
[else next])] [else next0]))
[(index) (let loop ([d d]) (define index
(let ([p (part-parent d ri)]) (let loop ([d d])
(if p (let ([p (part-parent d ri)])
(loop p) (if p
(let ([subs (part-parts d)]) (loop p)
(and (pair? subs) (let ([subs (part-parts d)])
(let ([d (car (last-pair subs))]) (and (pair? subs)
(and (part-style? d 'index) (let ([d (last subs)])
d)))))))]) (and (part-style? d 'index)
(define (render . content) d))))))))
(render-content content d ri)) (define (render . content) (render-content content d ri))
(if (not (or prev next parent index up-path)) (if (not (or prev next parent index up-path))
null null
`(,@(if pre-space? '((p nbsp)) null) `(,@(if pre-space? '((p nbsp)) null)
(div ([class "navleft"]) (div ([class "navleft"])
,@(render (make-element ,@(render (make-element
(if parent (if parent
(make-target-url "index.html" #f) (make-target-url "index.html" #f)
"nonavigation") "nonavigation")
contents-content)) contents-content))
,@(if index ,@(if index
`(nbsp `(nbsp
,@(render (if (eq? d index) ,@(render (if (eq? d index)
(make-element "nonavigation" index-content) (make-element "nonavigation" index-content)
(make-link-element (make-link-element
#f index-content (car (part-tags index))))) #f index-content (car (part-tags index)))))
#; ; no need for these index-local searches #; ; no need for these index-local searches
,@(if (eq? d index) ,@(if (eq? d index)
null null
`((span ([class "smaller"]) nbsp ,(search-index-box))))) `((span ([class "smaller"]) nbsp ,(search-index-box)))))
null) null)
,@(if up-path ,@(if up-path
`(nbsp (span ([class "smaller"]) ,(search-index-box))) `(nbsp (span ([class "smaller"]) ,(search-index-box)))
null)) null))
(div ([class "navright"]) (div ([class "navright"])
,@(render ,@(render
(make-element (make-element
(if parent (if parent
(make-target-url (make-target-url (if prev (derive-filename prev) "index.html")
(if prev (derive-filename prev) "index.html") #f)
#f) "nonavigation")
"nonavigation") prev-content)
prev-content) sep-element
sep-element (make-element
(make-element (cond
(cond ;; up-path = #t => go up to the start page, using
;; up-path = #t => go up to the start page, using ;; cookies to get to the user's version of it (see
;; cookies to get to the user's version of it (see ;; scribblings/main/private/utils for the code that
;; scribblings/main/private/utils for the code ;; creates these cookies.)
;; that creates these cookies.) [(and (eq? #t up-path) (not parent))
[(and (eq? #t up-path) (not parent)) (make-target-url
(make-target-url "../index.html"
"../index.html" (make-with-attributes
(make-with-attributes #f `([onclick . ,(format "return GotoPLTRoot(\"~a\");"
#f `([onclick (version))])))]
. ,(format "return GotoPLTRoot(\"~a\");" [(or parent up-path)
(version))])))] (make-target-url
[(or parent up-path) (cond [(not parent) up-path]
(make-target-url [(and (toc-part? parent) (part-parent parent ri))
(cond [(not parent) up-path] (derive-filename parent)]
[(and (toc-part? parent) (part-parent parent ri)) [else "index.html"])
(derive-filename parent)] #f)]
[else "index.html"]) [else "nonavigation"])
#f)] up-content)
[else "nonavigation"]) sep-element
up-content) (make-element (if next
sep-element (make-target-url (derive-filename next) #f)
(make-element "nonavigation")
(if next next-content)))
(make-target-url (derive-filename next) #f) (p nbsp))))
"nonavigation")
next-content)))
(p nbsp)))))
(define/override (render-one d ri fn) (define/override (render-one d ri fn)
(render-one-part d ri fn null)) (render-one-part d ri fn null))