add master index
svn: r8310 original commit: 13025bff7a53c82b0367ece5932fc92b3150f50c
This commit is contained in:
Matthew Flatt
parent
77f98c97a8
commit
6389cc8931
|
|
@ -157,7 +157,7 @@
|
|||
|
||||
;; ----------------------------------------
|
||||
|
||||
(provide section-index index index* as-index index-section)
|
||||
(provide section-index index index* as-index index-section index-flow-elements)
|
||||
|
||||
(define (section-index . elems)
|
||||
(make-part-index-decl (map element->string elems) elems))
|
||||
|
|
@ -192,58 +192,107 @@
|
|||
key
|
||||
content)))
|
||||
|
||||
(define (index-section #:tag [tag #f])
|
||||
(define (index-section #:title [title "Index"] #:tag [tag #f])
|
||||
(make-unnumbered-part
|
||||
#f
|
||||
`((part ,(or tag "doc-index")))
|
||||
'("Index")
|
||||
(list title)
|
||||
'index
|
||||
null
|
||||
(make-flow (list (make-delayed-flow-element
|
||||
(lambda (renderer sec ri)
|
||||
(let ([l null])
|
||||
(hash-table-for-each
|
||||
(collected-info-info
|
||||
(part-collected-info
|
||||
(collected-info-parent
|
||||
(part-collected-info sec ri))
|
||||
ri))
|
||||
(lambda (k v)
|
||||
(when (and (pair? k)
|
||||
(eq? 'index-entry (car k)))
|
||||
(set! l (cons (cons (cadr k) v) l)))))
|
||||
(let ([l (sort
|
||||
l
|
||||
(lambda (a b)
|
||||
(let loop ([a (cadr a)][b (cadr b)])
|
||||
(cond
|
||||
[(null? a) #t]
|
||||
[(null? b) #f]
|
||||
[(string-ci=? (car a) (car b))
|
||||
(loop (cdr a) (cdr b))]
|
||||
[else
|
||||
(string-ci<? (car a) (car b))]))))]
|
||||
[commas (lambda (l)
|
||||
(if (or (null? l)
|
||||
(null? (cdr l)))
|
||||
l
|
||||
(cdr (apply append (map (lambda (i)
|
||||
(list ", " i))
|
||||
l)))))])
|
||||
(make-table
|
||||
'index
|
||||
(map (lambda (i)
|
||||
(list (make-flow
|
||||
(list
|
||||
(make-paragraph
|
||||
(list
|
||||
(make-link-element
|
||||
"indexlink"
|
||||
(commas (caddr i))
|
||||
(car i))))))))
|
||||
l))))))))
|
||||
(make-flow (index-flow-elements))
|
||||
null))
|
||||
|
||||
(define (index-flow-elements)
|
||||
(list (make-delayed-flow-element
|
||||
(lambda (renderer sec ri)
|
||||
(let ([l null])
|
||||
(hash-table-for-each
|
||||
(let ([parent (collected-info-parent
|
||||
(part-collected-info sec ri))])
|
||||
(if parent
|
||||
(collected-info-info
|
||||
(part-collected-info
|
||||
parent
|
||||
ri))
|
||||
(collect-info-ext-ht (resolve-info-ci ri))))
|
||||
(lambda (k v)
|
||||
(when (and (pair? k)
|
||||
(eq? 'index-entry (car k)))
|
||||
(set! l (cons (cons (cadr k) v) l)))))
|
||||
(let ([l (sort
|
||||
l
|
||||
(lambda (a b)
|
||||
(let loop ([a (cadr a)][b (cadr b)])
|
||||
(cond
|
||||
[(null? a) #t]
|
||||
[(null? b) #f]
|
||||
[(string-ci=? (car a) (car b))
|
||||
(loop (cdr a) (cdr b))]
|
||||
[else
|
||||
(string-ci<? (car a) (car b))]))))]
|
||||
[commas (lambda (l)
|
||||
(if (or (null? l)
|
||||
(null? (cdr l)))
|
||||
l
|
||||
(cdr (apply append (map (lambda (i)
|
||||
(list ", " i))
|
||||
l)))))]
|
||||
[alpha-starts (make-hash-table)])
|
||||
(make-table
|
||||
'index
|
||||
(list*
|
||||
(list
|
||||
(make-flow
|
||||
(list
|
||||
(make-paragraph
|
||||
(let ([add-letter
|
||||
(lambda (letter l)
|
||||
(list* (make-element "nonavigation"
|
||||
(list (string letter)))
|
||||
" "
|
||||
l))])
|
||||
(let loop ([i l]
|
||||
[alpha (string->list "ABCDEFGHIJKLMNOPQRSTUVWXYZ")])
|
||||
(cond
|
||||
[(null? alpha) null]
|
||||
[(null? i) (add-letter (car alpha)
|
||||
(loop i (cdr alpha)))]
|
||||
[else (let* ([strs (cadr (car i))]
|
||||
[letter (if (or (null? strs)
|
||||
(string=? "" (car strs)))
|
||||
#f
|
||||
(string-ref (car strs) 0))])
|
||||
(cond
|
||||
[(not letter) (loop (cdr i) alpha)]
|
||||
[(char-ci>? letter (car alpha))
|
||||
(add-letter (car alpha)
|
||||
(loop i (cdr alpha)))]
|
||||
[(char-ci=? letter (car alpha))
|
||||
(hash-table-put! alpha-starts (car i) letter)
|
||||
(list* (make-element (make-target-url
|
||||
(format "#alpha:~a" letter)
|
||||
#f)
|
||||
(list (string (car alpha))))
|
||||
" "
|
||||
(loop (cdr i) (cdr alpha)))]
|
||||
[else (loop (cdr i) alpha)]))])))))))
|
||||
(list (make-flow (list (make-paragraph (list 'nbsp)))))
|
||||
(map (lambda (i)
|
||||
(list (make-flow
|
||||
(list
|
||||
(make-paragraph
|
||||
(list
|
||||
(let ([e (make-link-element
|
||||
"indexlink"
|
||||
(commas (caddr i))
|
||||
(car i))])
|
||||
(let ([letter (hash-table-get alpha-starts i #f)])
|
||||
(if letter
|
||||
(make-element (make-url-anchor (format "alpha:~a" letter))
|
||||
(list e))
|
||||
e)))))))))
|
||||
l)))))))))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(provide table-of-contents
|
||||
|
|
|
|||
|
|
@ -182,7 +182,7 @@
|
|||
(part-parts (caar l)))
|
||||
(cdr l))))]
|
||||
[else (cons (car l) (loop (cdr l)))])))])
|
||||
(if (null? toc-content)
|
||||
(if (and #f (null? toc-content))
|
||||
null
|
||||
`((div ((class "tocview"))
|
||||
(div ((class "tocviewtitle"))
|
||||
|
|
@ -253,6 +253,8 @@
|
|||
(cond
|
||||
[(toc-target-element? a)
|
||||
(cons a (loop (cdr c)))]
|
||||
[(toc-element? a)
|
||||
(cons a (loop (cdr c)))]
|
||||
[(element? a)
|
||||
(append (loop (element-content a))
|
||||
(loop (cdr c)))]
|
||||
|
|
@ -284,25 +286,27 @@
|
|||
((class "tocsublist")
|
||||
(cellspacing "0"))
|
||||
,@(map (lambda (p)
|
||||
(parameterize ([current-no-links #t]
|
||||
[extra-breaking? #t])
|
||||
`(tr
|
||||
(td
|
||||
,@(if (part? p)
|
||||
`((span ((class "tocsublinknumber"))
|
||||
,@(format-number (collected-info-number
|
||||
(part-collected-info p ri))
|
||||
'((tt nbsp)))))
|
||||
'(""))
|
||||
(a ((href ,(if (part? p)
|
||||
(format "#~a" (anchor-name (tag-key (car (part-tags p)) ri)))
|
||||
(format "#~a" (anchor-name (tag-key (target-element-tag p) ri)))))
|
||||
(class ,(if (part? p)
|
||||
"tocsubseclink"
|
||||
"tocsublink")))
|
||||
,@(if (part? p)
|
||||
(render-content (or (part-title-content p) '("???")) d ri)
|
||||
(render-content (element-content p) d ri)))))))
|
||||
`(tr
|
||||
(td
|
||||
,@(if (part? p)
|
||||
`((span ((class "tocsublinknumber"))
|
||||
,@(format-number (collected-info-number
|
||||
(part-collected-info p ri))
|
||||
'((tt nbsp)))))
|
||||
'(""))
|
||||
,@(if (toc-element? p)
|
||||
(render-content (toc-element-toc-content p) d ri)
|
||||
(parameterize ([current-no-links #t]
|
||||
[extra-breaking? #t])
|
||||
`((a ((href ,(if (part? p)
|
||||
(format "#~a" (anchor-name (tag-key (car (part-tags p)) ri)))
|
||||
(format "#~a" (anchor-name (tag-key (target-element-tag p) ri)))))
|
||||
(class ,(if (part? p)
|
||||
"tocsubseclink"
|
||||
"tocsublink")))
|
||||
,@(if (part? p)
|
||||
(render-content (or (part-title-content p) '("???")) d ri)
|
||||
(render-content (element-content p) d ri)))))))))
|
||||
ps))))))))
|
||||
|
||||
(define/public (render-one-part d ri fn number)
|
||||
|
|
@ -478,7 +482,14 @@
|
|||
(if (current-no-links)
|
||||
(super render-element e part ri)
|
||||
(parameterize ([current-no-links #t])
|
||||
`((a ((href ,(target-url-addr style))) ,@(super render-element e part ri)))))]
|
||||
`((a ((href ,(target-url-addr style))
|
||||
,@(if (string? (target-url-style style))
|
||||
`((class ,(target-url-style style)))
|
||||
null))
|
||||
,@(super render-element e part ri)))))]
|
||||
[(url-anchor? style)
|
||||
`((a ((name ,(url-anchor-name style)))
|
||||
,@(super render-element e part ri)))]
|
||||
[(image-file? style) `((img ((src ,(install-file (image-file-path style))))))]
|
||||
[else (super render-element e part ri)])))
|
||||
|
||||
|
|
@ -737,7 +748,7 @@
|
|||
(list
|
||||
(make-element
|
||||
(if parent
|
||||
(make-target-url "index.html")
|
||||
(make-target-url "index.html" #f)
|
||||
"nonavigation")
|
||||
contents-content))
|
||||
(if index
|
||||
|
|
@ -761,7 +772,8 @@
|
|||
(if parent
|
||||
(make-target-url (if prev
|
||||
(derive-filename prev)
|
||||
"index.html"))
|
||||
"index.html")
|
||||
#f)
|
||||
"nonavigation")
|
||||
prev-content)
|
||||
sep-element
|
||||
|
|
@ -770,13 +782,14 @@
|
|||
(make-target-url
|
||||
(if (toc-part? parent)
|
||||
(derive-filename parent)
|
||||
"index.html"))
|
||||
"index.html")
|
||||
#f)
|
||||
"nonavigation")
|
||||
up-content)
|
||||
sep-element
|
||||
(make-element
|
||||
(if next
|
||||
(make-target-url (derive-filename next))
|
||||
(make-target-url (derive-filename next) #f)
|
||||
"nonavigation")
|
||||
next-content))
|
||||
d
|
||||
|
|
|
|||
|
|
@ -244,9 +244,12 @@
|
|||
[opt (cond
|
||||
[(equal? tableform "longtable") "[l]"]
|
||||
[(equal? tableform "tabular") "[t]"]
|
||||
[else ""])])
|
||||
(unless (or (null? (table-flowss t))
|
||||
(null? (car (table-flowss t))))
|
||||
[else ""])]
|
||||
[flowss (if index?
|
||||
(cddr (table-flowss t))
|
||||
(table-flowss t))])
|
||||
(unless (or (null? flowss)
|
||||
(null? (car flowss)))
|
||||
(parameterize ([current-table-mode (if inline?
|
||||
(current-table-mode)
|
||||
(list tableform t))]
|
||||
|
|
@ -273,14 +276,14 @@
|
|||
[(center) "c"]
|
||||
[(right) "r"]
|
||||
[else "l"])))
|
||||
(car (table-flowss t))
|
||||
(car flowss)
|
||||
(cdr (or (and (list? (table-style t))
|
||||
(assoc 'alignment (or (table-style t) null)))
|
||||
(cons #f (map (lambda (x) #f) (car (table-flowss t)))))))))])
|
||||
(let loop ([flowss (table-flowss t)]
|
||||
(cons #f (map (lambda (x) #f) (car flowss))))))))])
|
||||
(let loop ([flowss flowss]
|
||||
[row-styles (cdr (or (and (list? (table-style t))
|
||||
(assoc 'row-styles (table-style t)))
|
||||
(cons #f (map (lambda (x) #f) (table-flowss t)))))])
|
||||
(cons #f (map (lambda (x) #f) flowss))))])
|
||||
(let ([flows (car flowss)]
|
||||
[row-style (car row-styles)])
|
||||
(let loop ([flows flows])
|
||||
|
|
|
|||
|
|
@ -306,8 +306,11 @@
|
|||
(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)))
|
||||
(define (link url #:underline? [underline? #t] . str)
|
||||
(make-element (make-target-url url (if underline?
|
||||
#f
|
||||
"plainlink"))
|
||||
(decode-content str)))
|
||||
|
||||
(define (schemeerror . str)
|
||||
(make-element "schemeerror" (decode-content str)))
|
||||
|
|
|
|||
|
|
@ -136,7 +136,6 @@ font-weight: bold;
|
|||
}
|
||||
|
||||
.tocsub {
|
||||
margin-top: 1em;
|
||||
text-align: left;
|
||||
background-color: #DCF5F5;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -158,6 +158,7 @@
|
|||
;; content = list of elements
|
||||
[element ([style any/c]
|
||||
[content list?])]
|
||||
[(toc-element element) ([toc-content list?])]
|
||||
[(target-element element) ([tag tag?])]
|
||||
[(toc-target-element target-element) ()]
|
||||
[(page-target-element target-element) ()]
|
||||
|
|
@ -174,7 +175,8 @@
|
|||
[parent (or/c false/c part?)]
|
||||
[info any/c])]
|
||||
|
||||
[target-url ([addr string?])]
|
||||
[target-url ([addr string?][style any/c])]
|
||||
[url-anchor ([name string?])]
|
||||
[image-file ([path path-string?])])
|
||||
|
||||
;; ----------------------------------------
|
||||
|
|
|
|||
|
|
@ -462,9 +462,11 @@ Computed for each part by the @techlink{collect pass}.
|
|||
}
|
||||
|
||||
|
||||
@defstruct[target-url ([addr string?])]{
|
||||
@defstruct[target-url ([addr string?]
|
||||
[style any/c])]{
|
||||
|
||||
Used as a style for an @scheme[element].}
|
||||
Used as a style for an @scheme[element]. The @scheme[style] at this
|
||||
layer is a style for the hyperlink.}
|
||||
|
||||
|
||||
@defstruct[image-file ([path path-string?])]{
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user