From a05fd5eb87bc32d033fa98e01cf147e5bbfbea4b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 9 Feb 2008 13:01:39 +0000 Subject: [PATCH] doc and test repairs svn: r8597 original commit: 1959c567431344b468d47fa873e093b5ab0787c4 --- collects/scribble/basic.ss | 9 +++- collects/scribble/run.ss | 2 +- collects/scribble/scheme.ss | 89 ++++++++++++++++++++++++++----------- 3 files changed, 72 insertions(+), 28 deletions(-) diff --git a/collects/scribble/basic.ss b/collects/scribble/basic.ss index 9408f0c0..b83ba4ad 100644 --- a/collects/scribble/basic.ss +++ b/collects/scribble/basic.ss @@ -111,8 +111,15 @@ tt span-class subscript superscript) +(define hspace-cache (make-vector 100 #f)) + (define (hspace n) - (make-element 'hspace (list (make-string n #\space)))) + (if (n . < . (vector-length hspace-cache)) + (or (vector-ref hspace-cache n) + (let ([h (make-element 'hspace (list (make-string n #\space)))]) + (vector-set! hspace-cache n h) + h)) + (make-element 'hspace (list (make-string n #\space))))) (define (elem . str) (make-element #f (decode-content str))) diff --git a/collects/scribble/run.ss b/collects/scribble/run.ss index af777dfb..b491d36c 100644 --- a/collects/scribble/run.ss +++ b/collects/scribble/run.ss @@ -58,7 +58,7 @@ (define (build-docs-files files) (build-docs (map (lambda (file) - (dynamic-require file 'doc)) + (dynamic-require `(file ,file) 'doc)) files) files)) diff --git a/collects/scribble/scheme.ss b/collects/scribble/scheme.ss index 16394d9a..30ceba97 100644 --- a/collects/scribble/scheme.ss +++ b/collects/scribble/scheme.ss @@ -54,11 +54,57 @@ (make-spaces #f (list (literalize-spaces (substring i 0 (caar m))) - (make-element 'hspace (list (make-string cnt #\space))) + (hspace cnt) (literalize-spaces (substring i (cdar m)))) cnt)) i))) + + (define line-breakable-space (make-element 'tt (list " "))) + + (define id-element-cache #f #;(make-hash-table 'equal)) + (define element-cache #f #;(make-hash-table 'equal)) + + (define (make-id-element c s) + (let* ([key (and id-element-cache + (let ([b (identifier-label-binding c)]) + (list (syntax-e c) + (module-path-index-resolve (caddr b)) + (cadddr b) + (list-ref b 5))))]) + (or (and key + (hash-table-get id-element-cache key #f)) + (let ([e (make-delayed-element + (lambda (renderer sec ri) + (let* ([tag (find-scheme-tag sec ri c 'for-label)]) + (if tag + (list + (case (car tag) + [(form) + (make-link-element "schemesyntaxlink" (list s) tag)] + [else + (make-link-element "schemevaluelink" (list s) tag)])) + (list + (make-element "badlink" + (list (make-element "schemevaluelink" (list s)))))))) + (lambda () s) + (lambda () s))]) + (when key + (hash-table-put! id-element-cache key e)) + e)))) + + (define (make-element/cache style content) + (if (and element-cache + (pair? content) + (string? (car content)) + (null? (cdr content))) + (let ([key (cons style content)]) + (or (hash-table-get element-cache key #f) + (let ([e (make-element style content)]) + (hash-table-put! element-cache key e) + e))) + (make-element style content))) + (define (typeset-atom c out color? quote-depth) (let*-values ([(is-var?) (and (identifier? c) (memq (syntax-e c) (current-variable-list)))] @@ -81,21 +127,7 @@ (quote-depth . <= . 0) (not (or it? is-var?))) (if (pair? (identifier-label-binding c)) - (make-delayed-element - (lambda (renderer sec ri) - (let* ([tag (find-scheme-tag sec ri c 'for-label)]) - (if tag - (list - (case (car tag) - [(form) - (make-link-element "schemesyntaxlink" (list s) tag)] - [else - (make-link-element "schemevaluelink" (list s) tag)])) - (list - (make-element "badlink" - (list (make-element "schemevaluelink" (list s)))))))) - (lambda () s) - (lambda () s)) + (make-id-element c s) s) (literalize-spaces s)) (cond @@ -183,7 +215,7 @@ (make-element "highlighted" (list c))) values) (if (and color? cls) - (make-element cls (list v)) + (make-element/cache cls (list v)) v)) content)) (set! dest-col (+ dest-col len))]))])) @@ -208,8 +240,8 @@ (when (positive? amt) (let ([old-dest-col dest-col]) (out (if (and (= 1 amt) (not multi-line?)) - (make-element 'tt (list " ")) ; allows a line break to replace the space - (make-element 'hspace (list (make-string amt #\space)))) + line-breakable-space ; allows a line break to replace the space + (hspace amt)) #f) (set! dest-col (+ old-dest-col amt)))))) (set! src-col c) @@ -240,9 +272,9 @@ (make-sized-element (if val? value-color #f) (list - (make-element (if val? value-color paren-color) '(". ")) + (make-element/cache (if val? value-color paren-color) '(". ")) (typeset a #f "" "" "" (not val?)) - (make-element (if val? value-color paren-color) '(" ."))) + (make-element/cache (if val? value-color paren-color) '(" ."))) (+ (syntax-span a) 4))) (list (syntax-source a) (syntax-line a) @@ -480,11 +512,16 @@ (graph-reference? s)) (gen-typeset c multi-line? prefix1 prefix suffix color?) (typeset-atom c - (case-lambda - [(elem color) - (make-sized-element (and color? color) (list elem) (or (syntax-span c) 1))] - [(elem color len) - (make-sized-element (and color? color) (list elem) len)]) + (letrec ([mk + (case-lambda + [(elem color) + (mk elem color (or (syntax-span c) 1))] + [(elem color len) + (if (and (string? elem) + (= len (string-length elem))) + (make-element/cache (and color? color) (list elem)) + (make-sized-element (and color? color) (list elem) len))])]) + mk) color? 0)))) (define (to-element c)