diff --git a/collects/scribble/base-render.ss b/collects/scribble/base-render.ss index fb220cc8..78d23fab 100644 --- a/collects/scribble/base-render.ss +++ b/collects/scribble/base-render.ss @@ -383,6 +383,7 @@ (define/public (render-element i part ri) (cond + [(string? i) (render-other i part ri)] ; short-cut for common case [(and (link-element? i) (null? (element-content i))) (let ([v (resolve-get part ri (link-element-tag i))]) diff --git a/collects/scribble/basic.ss b/collects/scribble/basic.ss index 3ad5099b..a3c99364 100644 --- a/collects/scribble/basic.ss +++ b/collects/scribble/basic.ss @@ -127,11 +127,11 @@ v))) v))) -(define (module-path-index->taglet mod) +(define (do-module-path-index->taglet mod) ;; Derive the name from the module path: (let ([p (collapse-module-path-index mod - (build-path (current-directory) "dummy"))]) + (lambda () (build-path (current-directory) "dummy")))]) (if (path? p) ;; If we got a path back anyway, then it's best to use the resolved ;; name; if the current directory has changed since we @@ -160,6 +160,13 @@ p)]) (intern-taglet p))))) +(define collapsed (make-weak-hasheq)) +(define (module-path-index->taglet mod) + (or (hash-ref collapsed mod #f) + (let ([v (do-module-path-index->taglet mod)]) + (hash-set! collapsed mod v) + v))) + (define (module-path-prefix->string p) (format "~a" (module-path-index->taglet (module-path-index-join p #f)))) diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss index a67e5d19..7cc500a2 100644 --- a/collects/scribble/html-render.ss +++ b/collects/scribble/html-render.ss @@ -91,18 +91,16 @@ (define (anchor-name v) (define (encode-byte b) (string-append (if (< b 16) "~0" "~") (number->string b 16))) - (define (encode-str str) - (if (regexp-match? #px"[^[:ascii:]]" str) - (string-append* (map encode-byte (bytes->list (string->bytes/utf-8 str)))) - (encode-byte (char->integer (string-ref str 0))))) + (define (encode-bytes str) + (string->bytes/utf-8 (encode-byte (bytes-ref str 0)))) (if (literal-anchor? v) (literal-anchor-string v) - (let* ([v (format "~a" v)] - [v (regexp-replace* #rx"[A-Z.]" v ".&")] - [v (regexp-replace* #rx" " v "._")] - [v (regexp-replace* #rx"\"" v ".'")] - [v (regexp-replace* #rx"[^-a-zA-Z0-9_!+*'()/.,]" v encode-str)]) - v))) + (let* ([v (string->bytes/utf-8 (format "~a" v))] + [v (regexp-replace* #rx#"[A-Z.]" v #".&")] + [v (regexp-replace* #rx#" " v #"._")] + [v (regexp-replace* #rx#"\"" v #".'")] + [v (regexp-replace* #rx#"[^-a-zA-Z0-9_!+*'()/.,]" v encode-bytes)]) + (bytes->string/utf-8 v)))) (define-serializable-struct literal-anchor (string)) @@ -826,6 +824,7 @@ (define/override (render-element e part ri) (cond + [(string? e) (super render-element e part ri)] ; short-cut for common case [(hover-element? e) `((span ([title ,(hover-element-text e)]) ,@(render-plain-element e part ri)))] @@ -1270,9 +1269,16 @@ (loop (cdr path) (cdr root)))))) roots)))) +(define exploded (make-weak-hash)) +(define (explode/cache p) + (or (hash-ref exploded p #f) + (let ([v (explode p)]) + (hash-set! exploded p v) + v))) + (define (from-root p d) - (define e-p (explode (path->complete-path p (current-directory)))) - (define e-d (and d (explode (path->complete-path d (current-directory))))) + (define e-p (explode/cache (path->complete-path p (current-directory)))) + (define e-d (and d (explode/cache (path->complete-path d (current-directory))))) (define p-in? (in-plt? e-p)) (define d-in? (and d (in-plt? e-d))) ;; use an absolute link if the link is from outside the plt tree @@ -1287,12 +1293,13 @@ (let loop ([e-d e-d] [e-p e-p]) (cond [(null? e-d) - (let loop ([e-p e-p]) - (cond [(null? e-p) "/"] - [(null? (cdr e-p)) (car e-p)] - [(eq? 'same (car e-p)) (loop (cdr e-p))] - [(eq? 'up (car e-p)) (string-append "../" (loop (cdr e-p)))] - [else (string-append (car e-p) "/" (loop (cdr e-p)))]))] + (string-append* + (let loop ([e-p e-p]) + (cond [(null? e-p) '("/")] + [(null? (cdr e-p)) (list (car e-p))] + [(eq? 'same (car e-p)) (loop (cdr e-p))] + [(eq? 'up (car e-p)) (cons "../" (loop (cdr e-p)))] + [else (cons (car e-p) (cons "/" (loop (cdr e-p))))])))] [(equal? (car e-d) (car e-p)) (loop (cdr e-d) (cdr e-p))] [(eq? 'same (car e-d)) (loop (cdr e-d) e-p)] [(eq? 'same (car e-p)) (loop e-d (cdr e-p))] diff --git a/collects/scribble/private/manual-proc.ss b/collects/scribble/private/manual-proc.ss index d503c96c..d5df2e00 100644 --- a/collects/scribble/private/manual-proc.ss +++ b/collects/scribble/private/manual-proc.ss @@ -295,8 +295,9 @@ (*sig-elem (sig-id sig) (extract-id prototype)) (to-element (make-just-context (extract-id prototype) stx-id)))))])) + (define p-depth (prototype-depth prototype)) (define flat-size (+ (prototype-size args + + #f) - (prototype-depth prototype) + p-depth (element-width tagged))) (define short? (or (flat-size . < . 40) ((length args) . < . 2))) (define res @@ -319,7 +320,7 @@ (loop (cdr res)))))))))) res))) (define tagged+arg-width (+ (prototype-size args max max #t) - (prototype-depth prototype) + p-depth (element-width tagged))) (define result-next-line? ((+ (if short? flat-size tagged+arg-width) (block-width res)) @@ -339,10 +340,10 @@ (to-flow (make-element #f - `(,(make-openers (add1 (prototype-depth prototype))) + `(,(make-openers (add1 p-depth)) ,tagged ,@(if (null? args) - (list (make-closers (prototype-depth prototype))) + (list (make-closers p-depth)) (append-map (lambda (arg) (list spacer ((arg->elem #t) arg))) args)) @@ -363,7 +364,7 @@ (make-element #f (list - (make-openers (add1 (prototype-depth prototype))) + (make-openers (add1 p-depth)) tagged))) (if one-ok? (list*