commit f1a593d3a3337478db7381290316fdc0f7e6246f
parent c17636d399bf70c91d348854bd6ebce6306a87b3
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 9 Dec 2011 16:29:03 -0700
read-intern strings generated by Scribble; other interning
This change saves a small amount of space in cross-reference files
and some space in loaded cross-reference information.
It also saves work converting strings to mutable on deserialize,
although the performance difference seems negligible.
original commit: b2fade9206590173e4c2e346357ad13150525387
Diffstat:
11 files changed, 96 insertions(+), 68 deletions(-)
diff --git a/collects/scribble/base.rkt b/collects/scribble/base.rkt
@@ -40,10 +40,13 @@
(provide include-section)
(define (gen-tag content)
- (regexp-replace* "[^-a-zA-Z0-9_=]" (content->string content) "_"))
+ (read-intern-literal
+ (regexp-replace* "[^-a-zA-Z0-9_=]" (content->string content) "_")))
(define (prefix->string p)
- (and p (if (string? p) p (module-path-prefix->string p))))
+ (and p (if (string? p)
+ (read-intern-literal p)
+ (module-path-prefix->string p))))
(define (convert-tag tag content)
(if (list? tag)
@@ -171,7 +174,7 @@
(define (intern-taglet v)
(let ([v (if (list? v)
(map intern-taglet v)
- v)])
+ (read-intern-literal v))])
(if (or (string? v)
(bytes? v)
(list? v))
@@ -226,7 +229,8 @@
v)))
(define (module-path-prefix->string p)
- (format "~a" (module-path-index->taglet (module-path-index-join p #f))))
+ (read-intern-literal
+ (format "~a" (module-path-index->taglet (module-path-index-join p #f)))))
(define doc-prefix
(case-lambda
diff --git a/collects/scribble/decode.rkt b/collects/scribble/decode.rkt
@@ -88,7 +88,7 @@
(let* ([s (regexp-replace* #px"\\s+" s " ")]
[s (regexp-replace* #rx"^ " s "")]
[s (regexp-replace* #rx" $" s "")])
- s))
+ (read-intern-literal s)))
(define (decode-string s)
(let loop ([l '((#rx"---" mdash)
@@ -99,9 +99,10 @@
(cond [(null? l) (list s)]
[(regexp-match-positions (caar l) s)
=> (lambda (m)
- (append (decode-string (substring s 0 (caar m)))
- (cdar l)
- (decode-string (substring s (cdar m)))))]
+ (read-intern-literal
+ (append (decode-string (substring s 0 (caar m)))
+ (cdar l)
+ (decode-string (substring s (cdar m))))))]
[else (loop (cdr l))])))
(define (line-break? v)
diff --git a/collects/scribble/private/manual-bind.rkt b/collects/scribble/private/manual-bind.rkt
@@ -4,6 +4,8 @@
"../search.rkt"
"../basic.rkt"
"../manual-struct.rkt"
+ (only-in "../core.rkt" make-style)
+ "../html-properties.rkt"
"manual-ex.rkt"
racket/contract/base
(for-syntax scheme/base)
@@ -53,21 +55,28 @@
(lambda () s)
(lambda () s))))
+(define hovers (make-weak-hasheq))
+(define (intern-hover-style text)
+ (let ([text (read-intern-literal text)])
+ (or (hash-ref hovers text #f)
+ (let ([s (make-style #f (list (make-hover-property text)))])
+ (hash-set! hovers text s)
+ s))))
+
(define (annote-exporting-library e)
(make-delayed-element
(lambda (render p ri)
(let ([from (resolve-get/tentative p ri '(exporting-libraries #f))])
(if (and from (pair? from))
- (list (make-hover-element
- #f
- (list e)
- (intern-taglet
+ (list (make-element
+ (intern-hover-style
(string-append
"Provided from: "
(let loop ([from from])
(if (null? (cdr from))
(format "~s" (car from))
- (format "~s, ~a" (car from) (loop (cdr from)))))))))
+ (format "~s, ~a" (car from) (loop (cdr from)))))))
+ e))
(list e))))
(lambda () e)
(lambda () e)))
@@ -184,7 +193,7 @@
(if index?
(make-index-element
#f (list elem) tag
- (list (symbol->string (syntax-e id)))
+ (list (read-intern-literal (symbol->string (syntax-e id))))
(list elem)
(and show-libs?
(with-exporting-libraries
@@ -218,23 +227,25 @@
#f
(list (make-one (if form? 'form 'def))
(make-one 'dep)
- (make-index-element #f
- null
- (list (if form? 'form 'def)
- (list taglet id))
- (list (symbol->string id))
- (list
- (make-element
- symbol-color
+ (let ([str (read-intern-literal (symbol->string id))])
+ (make-index-element #f
+ null
+ (intern-taglet
+ (list (if form? 'form 'def)
+ (list taglet id)))
+ (list str)
(list
(make-element
- (if form?
- syntax-link-color
- value-link-color)
- (list (symbol->string id))))))
- ((if form?
- make-form-index-desc
- make-procedure-index-desc)
- id
- (list mod-path))))))))
+ symbol-color
+ (list
+ (make-element
+ (if form?
+ syntax-link-color
+ value-link-color)
+ (list str)))))
+ ((if form?
+ make-form-index-desc
+ make-procedure-index-desc)
+ id
+ (list mod-path)))))))))
redirects))))
diff --git a/collects/scribble/private/manual-class.rkt b/collects/scribble/private/manual-class.rkt
@@ -101,7 +101,7 @@
(if (hash-ref ht k #f)
#f
(begin (hash-set! ht k #t)
- (cons (symbol->string k)
+ (cons (read-intern-literal (symbol->string k))
(**method k (car super))))))
(cls/intf-methods (cdr super)))])
(if (null? inh)
@@ -133,7 +133,8 @@
symbol-color
(list (make-link-element
value-link-color
- (list (symbol->string (syntax-e (decl-name decl))))
+ (list (read-intern-literal
+ (symbol->string (syntax-e (decl-name decl)))))
tag)))
(map id-info (decl-app-mixins decl))
(and (decl-super decl)
@@ -206,7 +207,8 @@
(list
(make-index-element
#f content tag
- (list (symbol->string (syntax-e stx-id)))
+ (list (read-intern-literal
+ (symbol->string (syntax-e stx-id))))
content
(with-exporting-libraries
(lambda (libs)
diff --git a/collects/scribble/private/manual-form.rkt b/collects/scribble/private/manual-form.rkt
@@ -326,7 +326,7 @@
(if kw-id
(list (make-index-element
#f content tag
- (list (symbol->string (syntax-e kw-id)))
+ (list (read-intern-literal (symbol->string (syntax-e kw-id))))
content
(with-exporting-libraries
(lambda (libs)
diff --git a/collects/scribble/private/manual-mod.rkt b/collects/scribble/private/manual-mod.rkt
@@ -127,13 +127,14 @@
names
modpaths))
(append (map (lambda (modpath)
- (make-part-tag-decl `(mod-path ,(element->string modpath))))
+ (make-part-tag-decl `(mod-path ,(read-intern-literal
+ (element->string modpath)))))
modpaths)
(flow-paragraphs (decode-flow content)))))))
(define (make-defracketmodname mn mp)
- (let ([name-str (element->string mn)]
- [path-str (element->string mp)])
+ (let ([name-str (read-intern-literal (element->string mn))]
+ [path-str (read-intern-literal (element->string mp))])
(make-index-element #f
(list mn)
`(mod-path ,path-str)
diff --git a/collects/scribble/private/manual-proc.rkt b/collects/scribble/private/manual-proc.rkt
@@ -145,7 +145,7 @@
(if (eq? mode 'new)
(make-element
#f (list (racketparenfont "[")
- (racketidfont (keyword->string (arg-kw arg)))
+ (racketidfont (read-intern-literal (keyword->string (arg-kw arg))))
spacer
(to-element (make-var-id (arg-id arg)))
(racketparenfont "]")))
@@ -267,7 +267,7 @@
#f
content
tag
- (list (symbol->string mname))
+ (list (read-intern-literal (symbol->string mname)))
content
(with-exporting-libraries
(lambda (libs)
@@ -289,7 +289,7 @@
#f
(list (make-index-element
#f content tag
- (list (symbol->string (extract-id prototype)))
+ (list (read-intern-literal (symbol->string (extract-id prototype))))
content
(with-exporting-libraries
(lambda (libs)
@@ -899,7 +899,7 @@
#f
content
tag
- (list (symbol->string name))
+ (list (read-intern-literal (symbol->string name)))
content
(with-exporting-libraries
(lambda (libs) (make-thing-index-desc name libs)))))
@@ -942,7 +942,7 @@
(make-target-element*
make-target-element
stx-id
- (let* ([name (string-append* (map symbol->string (cdar wrappers)))]
+ (let* ([name (read-intern-literal (string-append* (map symbol->string (cdar wrappers))))]
[target-maker
(id-to-target-maker (datum->syntax stx-id (string->symbol name))
#t)])
diff --git a/collects/scribble/private/manual-scheme.rkt b/collects/scribble/private/manual-scheme.rkt
@@ -207,7 +207,7 @@
(define (*as-modname-link s e)
(make-link-element module-link-color
(list e)
- `(mod-path ,(format "~s" s))))
+ `(mod-path ,(read-intern-literal (format "~s" s)))))
(define-syntax-rule (indexed-racket x)
(add-racket-index 'x (racket x)))
diff --git a/collects/scribble/private/manual-style.rkt b/collects/scribble/private/manual-style.rkt
@@ -112,8 +112,9 @@
(define (indexed-file . str)
(let* ([f (apply filepath str)]
[s (element->string f)])
- (index* (list (clean-up-index-string
- (substring s 1 (sub1 (string-length s)))))
+ (index* (list (read-intern-literal
+ (clean-up-index-string
+ (substring s 1 (sub1 (string-length s))))))
(list f)
f)))
(define (exec . str)
diff --git a/collects/scribble/private/manual-tech.rkt b/collects/scribble/private/manual-tech.rkt
@@ -21,7 +21,8 @@
[s (string-foldcase (or key (content->string c)))]
[s (regexp-replace #rx"ies$" s "y")]
[s (regexp-replace #rx"s$" s "")]
- [s (regexp-replace* #px"[-\\s]+" s " ")])
+ [s (regexp-replace* #px"[-\\s]+" s " ")]
+ [s (read-intern-literal s)])
(make-elem style c (list 'tech (doc-prefix doc prefix s)))))
(define (deftech #:style? [style? #t] . s)
@@ -32,7 +33,8 @@
(make-index-element #f
(list t)
(target-element-tag t)
- (list (clean-up-index-string (element->string e)))
+ (list (read-intern-literal
+ (clean-up-index-string (element->string e))))
(list e)
'tech)))
diff --git a/collects/scribble/racket.rkt b/collects/scribble/racket.rkt
@@ -149,18 +149,19 @@
(lambda (renderer sec ri)
(let* ([tag (find-racket-tag sec ri c #f)])
(if tag
- (list
- (case (car tag)
- [(form)
- (make-link-element syntax-link-color (nonbreak-leading-hyphens s) tag)]
- [else
- (make-link-element value-link-color (nonbreak-leading-hyphens s) tag)]))
+ (let ([tag (intern-taglet tag)])
+ (list
+ (case (car tag)
+ [(form)
+ (make-link-element syntax-link-color (nonbreak-leading-hyphens s) tag)]
+ [else
+ (make-link-element value-link-color (nonbreak-leading-hyphens s) tag)])))
(list
(make-element "badlink"
(make-element value-link-color s))))))
(lambda () s)
(lambda () s)
- key)])
+ (intern-taglet key))])
(when key
(hash-set! id-element-cache key (make-weak-box e)))
e))))
@@ -194,13 +195,18 @@
(inc!)
(to-unquoted expr? (sub1 quote-depth) out color? inc!))))
+ (define iformat
+ (case-lambda
+ [(str val) (read-intern-literal (format str val))]
+ [(str . vals) (read-intern-literal (apply format str vals))]))
+
(define (typeset-atom c out color? quote-depth expr?)
(if (and (var-id? (syntax-e c))
(zero? quote-depth))
- (out (format "~s" (let ([v (var-id-sym (syntax-e c))])
- (if (syntax? v)
- (syntax-e v)
- v)))
+ (out (iformat "~s" (let ([v (var-id-sym (syntax-e c))])
+ (if (syntax? v)
+ (syntax-e v)
+ v)))
variable-color)
(let*-values ([(is-var?) (and (identifier? c)
(memq (syntax-e c) (current-variable-list)))]
@@ -208,8 +214,8 @@
(let ([sc (syntax-e c)])
(let ([s (cond
[(syntax-property c 'display-string) => values]
- [(literal-syntax? sc) (format "~s" (literal-syntax-stx sc))]
- [(var-id? sc) (format "~s" (var-id-sym sc))]
+ [(literal-syntax? sc) (iformat "~s" (literal-syntax-stx sc))]
+ [(var-id? sc) (iformat "~s" (var-id-sym sc))]
[(eq? sc #t)
(if (equal? (syntax-span c) 5)
"#true"
@@ -218,7 +224,7 @@
(if (equal? (syntax-span c) 6)
"#false"
"#f")]
- [else (format "~s" sc)])])
+ [else (iformat "~s" sc)])])
(if (and (symbol? sc)
((string-length s) . > . 1)
(char=? (string-ref s 0) #\_)
@@ -564,10 +570,10 @@
"cons"))]
[(vector? (syntax-e c)) "vector"]
[(mpair? (syntax-e c)) "mcons"]
- [else (format "~a"
- (if (struct-proxy? (syntax-e c))
- (syntax-e (struct-proxy-name (syntax-e c)))
- (object-name (syntax-e c))))])])
+ [else (iformat "~a"
+ (if (struct-proxy? (syntax-e c))
+ (syntax-e (struct-proxy-name (syntax-e c)))
+ (object-name (syntax-e c))))])])
(set! src-col (+ src-col (if (struct-proxy? (syntax-e c))
1
(string-length s))))
@@ -785,7 +791,7 @@
(set! src-col (+ orig-col (syntax-span c)))))]
[(graph-reference? (syntax-e c))
(advance c init-line!)
- (out (format "#~a#" (unbox (graph-reference-bx (syntax-e c))))
+ (out (iformat "#~a#" (unbox (graph-reference-bx (syntax-e c))))
(if (positive? quote-depth)
value-color
paren-color))
@@ -793,7 +799,7 @@
[(graph-defn? (syntax-e c))
(advance c init-line!)
(let ([bx (graph-defn-bx (syntax-e c))])
- (out (format "#~a=" (unbox bx))
+ (out (iformat "#~a=" (unbox bx))
(if (positive? quote-depth)
value-color
paren-color))
