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

read-intern strings generated by Scribble; other interning

Browse Source 
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
This commit is contained in:
Matthew Flatt 2011-12-09 16:29:03 -07:00
parent c17636d399
commit f1a593d3a3
11 changed files with 96 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/scribble/base.rkt
View File

@ -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

9
collects/scribble/decode.rkt
View File

@ -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)

57
collects/scribble/private/manual-bind.rkt
View File

@ -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))))

8
collects/scribble/private/manual-class.rkt
View File

@ -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)

2
collects/scribble/private/manual-form.rkt
View File

@ -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)

7
collects/scribble/private/manual-mod.rkt
View File

@ -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)

10
collects/scribble/private/manual-proc.rkt
View File

@ -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)])

2
collects/scribble/private/manual-scheme.rkt
View File

@ -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)))

5
collects/scribble/private/manual-style.rkt
View File

@ -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)

6
collects/scribble/private/manual-tech.rkt
View File

@ -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)))

46
collects/scribble/racket.rkt
View File

@ -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))