suzanne.soy/scribble-enhanced
1
0
Fork 0
Code Issues 1 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

add master index

Browse Source 
svn: r8310

original commit: 13025bff7a53c82b0367ece5932fc92b3150f50c
This commit is contained in:
Matthew Flatt 2008-01-12 18:32:30 +00:00
parent 77f98c97a8
commit 6389cc8931
7 changed files with 155 additions and 84 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

141
collects/scribble/basic.ss
View File

@ -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) (define (section-index . elems)
(make-part-index-decl (map element->string elems) elems)) (make-part-index-decl (map element->string elems) elems))
@ -192,58 +192,107 @@
key key
content))) content)))
(define (index-section #:tag [tag #f]) (define (index-section #:title [title "Index"] #:tag [tag #f])
(make-unnumbered-part (make-unnumbered-part
#f #f
`((part ,(or tag "doc-index"))) `((part ,(or tag "doc-index")))
'("Index") (list title)
'index 'index
null null
(make-flow (list (make-delayed-flow-element (make-flow (index-flow-elements))
(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))))))))
null)) 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 (provide table-of-contents

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

@ -182,7 +182,7 @@
(part-parts (caar l))) (part-parts (caar l)))
(cdr l))))] (cdr l))))]
[else (cons (car l) (loop (cdr l)))])))]) [else (cons (car l) (loop (cdr l)))])))])
(if (null? toc-content) (if (and #f (null? toc-content))
null null
`((div ((class "tocview")) `((div ((class "tocview"))
(div ((class "tocviewtitle")) (div ((class "tocviewtitle"))
@ -253,6 +253,8 @@
(cond (cond
[(toc-target-element? a) [(toc-target-element? a)
(cons a (loop (cdr c)))] (cons a (loop (cdr c)))]
[(toc-element? a)
(cons a (loop (cdr c)))]
[(element? a) [(element? a)
(append (loop (element-content a)) (append (loop (element-content a))
(loop (cdr c)))] (loop (cdr c)))]
@ -284,25 +286,27 @@
((class "tocsublist") ((class "tocsublist")
(cellspacing "0")) (cellspacing "0"))
,@(map (lambda (p) ,@(map (lambda (p)
(parameterize ([current-no-links #t] `(tr
[extra-breaking? #t]) (td
`(tr ,@(if (part? p)
(td `((span ((class "tocsublinknumber"))
,@(if (part? p) ,@(format-number (collected-info-number
`((span ((class "tocsublinknumber")) (part-collected-info p ri))
,@(format-number (collected-info-number '((tt nbsp)))))
(part-collected-info p ri)) '(""))
'((tt nbsp))))) ,@(if (toc-element? p)
'("")) (render-content (toc-element-toc-content p) d ri)
(a ((href ,(if (part? p) (parameterize ([current-no-links #t]
(format "#~a" (anchor-name (tag-key (car (part-tags p)) ri))) [extra-breaking? #t])
(format "#~a" (anchor-name (tag-key (target-element-tag p) ri))))) `((a ((href ,(if (part? p)
(class ,(if (part? p) (format "#~a" (anchor-name (tag-key (car (part-tags p)) ri)))
"tocsubseclink" (format "#~a" (anchor-name (tag-key (target-element-tag p) ri)))))
"tocsublink"))) (class ,(if (part? p)
,@(if (part? p) "tocsubseclink"
(render-content (or (part-title-content p) '("???")) d ri) "tocsublink")))
(render-content (element-content p) d ri))))))) ,@(if (part? p)
(render-content (or (part-title-content p) '("???")) d ri)
(render-content (element-content p) d ri)))))))))
ps)))))))) ps))))))))
(define/public (render-one-part d ri fn number) (define/public (render-one-part d ri fn number)
@ -478,7 +482,14 @@
(if (current-no-links) (if (current-no-links)
(super render-element e part ri) (super render-element e part ri)
(parameterize ([current-no-links #t]) (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))))))] [(image-file? style) `((img ((src ,(install-file (image-file-path style))))))]
[else (super render-element e part ri)]))) [else (super render-element e part ri)])))
@ -737,7 +748,7 @@
(list (list
(make-element (make-element
(if parent (if parent
(make-target-url "index.html") (make-target-url "index.html" #f)
"nonavigation") "nonavigation")
contents-content)) contents-content))
(if index (if index
@ -761,7 +772,8 @@
(if parent (if parent
(make-target-url (if prev (make-target-url (if prev
(derive-filename prev) (derive-filename prev)
"index.html")) "index.html")
#f)
"nonavigation") "nonavigation")
prev-content) prev-content)
sep-element sep-element
@ -770,13 +782,14 @@
(make-target-url (make-target-url
(if (toc-part? parent) (if (toc-part? parent)
(derive-filename parent) (derive-filename parent)
"index.html")) "index.html")
#f)
"nonavigation") "nonavigation")
up-content) up-content)
sep-element sep-element
(make-element (make-element
(if next (if next
(make-target-url (derive-filename next)) (make-target-url (derive-filename next) #f)
"nonavigation") "nonavigation")
next-content)) next-content))
d d

17
collects/scribble/latex-render.ss
View File

@ -244,9 +244,12 @@
[opt (cond [opt (cond
[(equal? tableform "longtable") "[l]"] [(equal? tableform "longtable") "[l]"]
[(equal? tableform "tabular") "[t]"] [(equal? tableform "tabular") "[t]"]
[else ""])]) [else ""])]
(unless (or (null? (table-flowss t)) [flowss (if index?
(null? (car (table-flowss t)))) (cddr (table-flowss t))
(table-flowss t))])
(unless (or (null? flowss)
(null? (car flowss)))
(parameterize ([current-table-mode (if inline? (parameterize ([current-table-mode (if inline?
(current-table-mode) (current-table-mode)
(list tableform t))] (list tableform t))]
@ -273,14 +276,14 @@
[(center) "c"] [(center) "c"]
[(right) "r"] [(right) "r"]
[else "l"]))) [else "l"])))
(car (table-flowss t)) (car flowss)
(cdr (or (and (list? (table-style t)) (cdr (or (and (list? (table-style t))
(assoc 'alignment (or (table-style t) null))) (assoc 'alignment (or (table-style t) null)))
(cons #f (map (lambda (x) #f) (car (table-flowss t)))))))))]) (cons #f (map (lambda (x) #f) (car flowss))))))))])
(let loop ([flowss (table-flowss t)] (let loop ([flowss flowss]
[row-styles (cdr (or (and (list? (table-style t)) [row-styles (cdr (or (and (list? (table-style t))
(assoc 'row-styles (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)] (let ([flows (car flowss)]
[row-style (car row-styles)]) [row-style (car row-styles)])
(let loop ([flows flows]) (let loop ([flows flows])

7
collects/scribble/manual.ss
View File

@ -306,8 +306,11 @@
(define (procedure . str) (define (procedure . str)
(make-element "schemeresult" (append (list "#<procedure:") (decode-content str) (list ">")))) (make-element "schemeresult" (append (list "#<procedure:") (decode-content str) (list ">"))))
(define (link url . str) (define (link url #:underline? [underline? #t] . str)
(make-element (make-target-url url) (decode-content str))) (make-element (make-target-url url (if underline?
#f
"plainlink"))
(decode-content str)))
(define (schemeerror . str) (define (schemeerror . str)
(make-element "schemeerror" (decode-content str))) (make-element "schemeerror" (decode-content str)))

1
collects/scribble/scribble.css
View File

@ -136,7 +136,6 @@ font-weight: bold;
} }
.tocsub { .tocsub {
margin-top: 1em;
text-align: left; text-align: left;
background-color: #DCF5F5; background-color: #DCF5F5;
} }

4
collects/scribble/struct.ss
View File

@ -158,6 +158,7 @@
;; content = list of elements ;; content = list of elements
[element ([style any/c] [element ([style any/c]
[content list?])] [content list?])]
[(toc-element element) ([toc-content list?])]
[(target-element element) ([tag tag?])] [(target-element element) ([tag tag?])]
[(toc-target-element target-element) ()] [(toc-target-element target-element) ()]
[(page-target-element target-element) ()] [(page-target-element target-element) ()]
@ -174,7 +175,8 @@
[parent (or/c false/c part?)] [parent (or/c false/c part?)]
[info any/c])] [info any/c])]
[target-url ([addr string?])] [target-url ([addr string?][style any/c])]
[url-anchor ([name string?])]
[image-file ([path path-string?])]) [image-file ([path path-string?])])
;; ---------------------------------------- ;; ----------------------------------------

6
collects/scribblings/scribble/struct.scrbl
View File

@ -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?])]{ @defstruct[image-file ([path path-string?])]{