commit 6612b39d5ea16ea369d4f4c395653f395d5c9959
parent 1c865ed71d6f913a8c94521c1efb4e550f7415c2
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Sat, 26 May 2007 06:31:34 +0000
continued work on the guide
svn: r6338
original commit: 5f37b5e912f099b1558b7a40ee950b3342a2dfa3
Diffstat:
5 files changed, 157 insertions(+), 56 deletions(-)
diff --git a/collects/scribble/base-render.ss b/collects/scribble/base-render.ss
@@ -278,7 +278,6 @@
(append
(format-number number
(list
- "."
(make-element 'hspace '(" "))))
(part-title-content part))
`(part ,(part-tag part))))))))
diff --git a/collects/scribble/eval.ss b/collects/scribble/eval.ss
@@ -122,19 +122,36 @@
(with-handlers ([exn? (lambda (e)
(exn-message e))])
(cons (let ([v (do-plain-eval s #t)])
- (copy-value v))
+ (copy-value v (make-hash-table)))
(get-output-string o)))))]))
+ (define (install ht v v2)
+ (hash-table-put! ht v v2)
+ v2)
+
;; Since we evaluate everything in an interaction before we typeset,
;; copy each value to avoid side-effects.
- (define (copy-value v)
+ (define (copy-value v ht)
(cond
- [(string? v) (string-copy v)]
- [(bytes? v) (bytes-copy v)]
- [(pair? v) (cons (copy-value (car v))
- (copy-value (cdr v)))]
+ [(and v (hash-table-get ht v #f))
+ => (lambda (v) v)]
+ [(string? v) (install ht v (string-copy v))]
+ [(bytes? v) (install ht v (bytes-copy v))]
+ [(pair? v) (let ([p (cons #f #f)])
+ (hash-table-put! ht v p)
+ (set-car! p (copy-value (car v) ht))
+ (set-cdr! p (copy-value (cdr v) ht))
+ p)]
+ [(vector? v) (let ([v2 (make-vector (vector-length v))])
+ (hash-table-put! ht v v2)
+ (let loop ([i (vector-length v2)])
+ (unless (zero? i)
+ (let ([i (sub1 i)])
+ (vector-set! v2 i (copy-value (vector-ref v i) ht))
+ (loop i))))
+ v2)]
[else v]))
-
+
(define (strip-comments s)
(cond
[(and (pair? s)
diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss
@@ -92,7 +92,7 @@
[(0) 'h2]
[(1) 'h3]
[else 'h4])
- ,@(format-number number '("." (tt nbsp)))
+ ,@(format-number number '((tt nbsp)))
,@(if (part-tag d)
`((a ((name ,(format "~a" `(part ,(part-tag d)))))))
null)
@@ -186,6 +186,7 @@
[(boxed) '((width "100%") (bgcolor "lightgray"))]
[(centered) '((align "center"))]
[(at-right) '((align "right"))]
+ [(at-left) '((align "left"))]
[else null]))
,@(map (lambda (flows)
`(tr ,@(map (lambda (d a)
@@ -278,6 +279,8 @@
ds
fns))
+ (define contents-content '("contents"))
+ (define index-content '("index"))
(define prev-content '(larr " prev"))
(define up-content '("up"))
(define next-content '("next " rarr))
@@ -299,9 +302,12 @@
(and (pair? (cdr l))
(cadr l)))]
[else (loop (cdr l) (car l))]))))
+
+ (define/private (part-parent d)
+ (collected-info-parent (part-collected-info d)))
(define/private (navigation d ht)
- (let ([parent (collected-info-parent (part-collected-info d))])
+ (let ([parent (part-parent d)])
(let*-values ([(prev next) (find-siblings d)]
[(prev) (if prev
(let loop ([prev prev])
@@ -322,39 +328,78 @@
(let-values ([(prev next)
(find-siblings parent)])
next)]
- [else next])])
- (render-table (make-table
- 'at-right
- (list
- (list
- (make-flow
- (list
- (make-paragraph
- (list
- (if parent
+ [else next])]
+ [(index) (let loop ([d d])
+ (let ([p (part-parent d)])
+ (if p
+ (loop p)
+ (let ([subs (part-parts d)])
+ (and (pair? subs)
+ (let ([d (car (last-pair subs))])
+ (and (equal? '("Index") (part-title-content d))
+ d)))))))])
+ `(,@(render-table (make-table
+ 'at-left
+ (list
+ (cons
+ (make-flow
+ (list
+ (make-paragraph
+ (list
(make-element
- (make-target-url (if prev
- (derive-filename prev)
- "index.html"))
+ (if parent
+ (make-target-url "index.html")
+ "nonavigation")
+ contents-content)))))
+ (if index
+ (list
+ (make-flow
+ (list
+ (make-paragraph
+ (list
+ 'nbsp
+ (if (eq? d index)
+ (make-element
+ "nonavigation"
+ index-content)
+ (make-link-element
+ #f
+ index-content
+ `(part ,(part-tag index)))))))))
+ null))))
+ d ht)
+ ,@(render-table (make-table
+ 'at-right
+ (list
+ (list
+ (make-flow
+ (list
+ (make-paragraph
+ (list
+ (make-element
+ (if parent
+ (make-target-url (if prev
+ (derive-filename prev)
+ "index.html"))
+ "nonavigation")
prev-content)
- "")
- sep-element
- (if parent
+ sep-element
(make-element
- (make-target-url
- (if (toc-part? parent)
- (derive-filename parent)
- "index.html"))
+ (if parent
+ (make-target-url
+ (if (toc-part? parent)
+ (derive-filename parent)
+ "index.html"))
+ "nonavigation")
up-content)
- "")
- sep-element
- (make-element
- (if next
- (make-target-url (derive-filename next))
- "nonavigation")
- next-content))))))))
- d
- ht))))
+ sep-element
+ (make-element
+ (if next
+ (make-target-url (derive-filename next))
+ "nonavigation")
+ next-content))))))))
+ d
+ ht)))))
(define/override (render-part d ht)
(let ([number (collected-info-number (part-collected-info d))])
diff --git a/collects/scribble/scheme.ss b/collects/scribble/scheme.ss
@@ -200,15 +200,21 @@
(convert-infix c quote-depth))
=> (lambda (converted)
((loop init-line! quote-depth) converted))]
- [(pair? (syntax-e c))
+ [(or (pair? (syntax-e c))
+ (vector? (syntax-e c)))
(let* ([sh (or (syntax-property c 'paren-shape)
#\()]
+ [quote-depth (if (vector? (syntax-e c))
+ +inf.0
+ quote-depth)]
[p-color (if (positive? quote-depth)
value-color
(if (eq? sh #\?)
opt-color
paren-color))])
(advance c init-line!)
+ (when (vector? (syntax-e c))
+ (out (format "#~a" (vector-length (syntax-e c))) p-color))
(out (case sh
[(#\[ #\?) "["]
[(#\{) "{"]
@@ -216,7 +222,9 @@
p-color)
(set! src-col (+ src-col 1))
(hash-table-put! col-map src-col dest-col)
- (let lloop ([l c])
+ (let lloop ([l (if (vector? (syntax-e c))
+ (vector->short-list (syntax-e c) syntax-e)
+ c)])
(cond
[(and (syntax? l)
(pair? (syntax-e l)))
@@ -357,6 +365,29 @@
(define syntax-ize-hook (make-parameter (lambda (v col) #f)))
+ (define (vector->short-list v extract)
+ (let ([l (vector->list v)])
+ (reverse (list-tail
+ (reverse l)
+ (- (vector-length v)
+ (let loop ([i (sub1 (vector-length v))])
+ (cond
+ [(zero? i) 1]
+ [(eq? (extract (vector-ref v i))
+ (extract (vector-ref v (sub1 i))))
+ (loop (sub1 i))]
+ [else (add1 i)])))))))
+
+ (define (short-list->vector v l)
+ (list->vector
+ (let ([n (length l)])
+ (if (n . < . (vector-length v))
+ (reverse (let loop ([r (reverse l)][i (- (vector-length v) n)])
+ (if (zero? i)
+ r
+ (loop (cons (car r) r) (sub1 i)))))
+ l))))
+
(define (syntax-ize v col)
(cond
[((syntax-ize-hook) v col)
@@ -370,20 +401,29 @@
c)
(list #f 1 col (+ 1 col)
(+ 1 (syntax-span c)))))]
- [(list? v)
- (let ([l (let loop ([col (+ col 1)]
- [v v])
- (if (null? v)
- null
- (let ([i (syntax-ize (car v) col)])
- (cons i
- (loop (+ col 1 (syntax-span i)) (cdr v))))))])
- (datum->syntax-object #f
- l
- (list #f 1 col (+ 1 col)
- (+ 2
- (sub1 (length l))
- (apply + (map syntax-span l))))))]
+ [(or (list? v)
+ (vector? v))
+ (let* ([vec-sz (if (vector? v)
+ (+ 1 (string-length (format "~a" (vector-length v))))
+ 0)])
+ (let ([l (let loop ([col (+ col 1 vec-sz)]
+ [v (if (vector? v)
+ (vector->short-list v values)
+ v)])
+ (if (null? v)
+ null
+ (let ([i (syntax-ize (car v) col)])
+ (cons i
+ (loop (+ col 1 (syntax-span i)) (cdr v))))))])
+ (datum->syntax-object #f
+ (if (vector? v)
+ (short-list->vector v l)
+ l)
+ (list #f 1 col (+ 1 col)
+ (+ 2
+ vec-sz
+ (sub1 (length l))
+ (apply + (map syntax-span l)))))))]
[(pair? v)
(let* ([a (syntax-ize (car v) (+ col 1))]
[sep (if (pair? (cdr v)) 0 3)]
diff --git a/collects/scribble/scribble.css b/collects/scribble/scribble.css
@@ -219,7 +219,7 @@
}
.nonavigation {
- color: gray;
+ color: #EEEEEE;
}
.disable {
