commit e192679a2b7ea0fd205c358517e9b9ff41ae152b
parent 1ca010cfb28f51a07d4bb69c0151e9a9c552013b
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Thu, 31 Jan 2008 00:06:54 +0000
small improvements to scribble data structures
svn: r8481
original commit: 7e6ef8eeb5bbd071ac41675fdd23246b928eedac
Diffstat:
8 files changed, 128 insertions(+), 73 deletions(-)
diff --git a/collects/scribble/base-render.ss b/collects/scribble/base-render.ss
@@ -70,7 +70,7 @@
(make-hash-table 'equal)
(make-hash-table)
(make-hash-table)
- ""
+ null
(make-hash-table)
null)])
(start-collect ds fns ci)
@@ -87,10 +87,9 @@
(collect-info-parts ci)
(collect-info-tags ci)
(if (part-tag-prefix d)
- (string-append (collect-info-gen-prefix ci)
- (part-tag-prefix d)
- ":")
- (collect-info-gen-prefix ci))
+ (append (collect-info-gen-prefix ci)
+ (list (part-tag-prefix d)))
+ (collect-info-gen-prefix ci))
(collect-info-relatives ci)
(cons d (collect-info-parents ci)))])
(when (part-title-content d)
@@ -115,14 +114,20 @@
(let ([prefix (part-tag-prefix d)])
(for ([(k v) (collect-info-ht p-ci)])
(when (cadr k)
- (collect-put! ci (if prefix (convert-key prefix k) k) v))))))
+ (collect-put! ci (if prefix
+ (convert-key prefix k)
+ k)
+ v))))))
(define/private (convert-key prefix k)
(case (car k)
[(part tech)
- (if (string? (cadr k))
- (list (car k) (string-append prefix ":" (cadr k)))
- k)]
+ (let ([rhs (cadr k)])
+ (if (or (string? rhs) (pair? rhs))
+ (list (car k) (cons prefix (if (pair? rhs)
+ rhs
+ (list rhs))))
+ k))]
[(index-entry)
(let ([v (convert-key prefix (cadr k))])
(if (eq? v (cadr k)) k (list 'index-entry v)))]
diff --git a/collects/scribble/basic.ss b/collects/scribble/basic.ss
@@ -180,7 +180,9 @@
(let ([key (make-generated-tag)]
[content (decode-content s)])
(record-index (list (content->string content))
- (list (make-element #f content))
+ (if (= 1 (length content))
+ content
+ (list (make-element #f content)))
key
content)))
diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss
@@ -179,7 +179,7 @@
(define/public (part-whole-page? p ri)
(let ([dest (resolve-get p ri (car (part-tags p)))])
- (caddr dest)))
+ (dest-page? dest)))
(define/public (current-part-whole-page? d)
(eq? d (current-top-part)))
@@ -189,21 +189,38 @@
(let ([key (generate-tag t ci)])
(collect-put! ci
key
- (list (path->relative (current-output-file))
- (or (part-title-content d)
- '("???"))
- (current-part-whole-page? d)
- (format "~a" key)))))
+ (vector (path->relative (current-output-file))
+ (or (part-title-content d)
+ '("???"))
+ (current-part-whole-page? d)
+ key))))
(part-tags d)))
(define/override (collect-target-element i ci)
(let ([key (generate-tag (target-element-tag i) ci)])
(collect-put! ci
key
- (list (path->relative (current-output-file))
- #f
- (page-target-element? i)
- (format "~a" key)))))
+ (vector (path->relative (current-output-file))
+ #f
+ (page-target-element? i)
+ key))))
+
+ (define (dest-path dest)
+ (if (vector? dest) ; temporary
+ (vector-ref dest 0)
+ (list-ref dest 0)))
+ (define (dest-title dest)
+ (if (vector? dest)
+ (vector-ref dest 1)
+ (list-ref dest 1)))
+ (define (dest-page? dest)
+ (if (vector? dest)
+ (vector-ref dest 2)
+ (list-ref dest 2)))
+ (define (dest-anchor dest)
+ (if (vector? dest)
+ (vector-ref dest 3)
+ (list-ref dest 3)))
;; ----------------------------------------
@@ -211,10 +228,10 @@
(let ([dest (resolve-get #f ri tag)])
(if dest
(values
- (relative->path (car dest))
- (if (caddr dest)
+ (relative->path (dest-path dest))
+ (if (dest-page? dest)
#f
- (anchor-name (cadddr dest))))
+ (anchor-name (dest-anchor dest))))
(values #f #f))))
;; ----------------------------------------
@@ -249,14 +266,14 @@
(td
(a ((href ,(let ([dest (resolve-get p ri (car (part-tags p)))])
(format "~a~a~a"
- (from-root (relative->path (car dest))
+ (from-root (relative->path (dest-path dest))
(get-dest-directory))
- (if (caddr dest)
+ (if (dest-page? dest)
""
"#")
- (if (caddr dest)
+ (if (dest-page? dest)
""
- (anchor-name (cadddr dest))))))
+ (anchor-name (dest-anchor dest))))))
(class ,(if (eq? p mine)
"tocviewselflink"
"tocviewlink")))
@@ -629,19 +646,19 @@
(let ([dest (resolve-get part ri (link-element-tag e))])
(if dest
`((a ((href ,(format "~a~a~a"
- (from-root (relative->path (car dest))
+ (from-root (relative->path (dest-path dest))
(get-dest-directory))
- (if (caddr dest)
+ (if (dest-page? dest)
""
"#")
- (if (caddr dest)
+ (if (dest-page? dest)
""
- (anchor-name (cadddr dest)))))
+ (anchor-name (dest-anchor dest)))))
,@(if (string? (element-style e))
`((class ,(element-style e)))
null))
,@(if (null? (element-content e))
- (render-content (strip-aux (cadr dest)) part ri)
+ (render-content (strip-aux (dest-title dest)) part ri)
(render-content (element-content e) part ri))))
(begin
(when #f
diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss
@@ -338,15 +338,14 @@
(annote-exporting-library
(to-element (make-just-context name stx-id))))))
- (define (libs->str libs)
+ (define (libs->taglet libs)
(and (pair? libs)
- (format "~a"
- (let ([p (resolved-module-path-name
- (module-path-index-resolve
- (module-path-index-join (car libs) #f)))])
- (if (path? p)
- (path->main-collects-relative p)
- p)))))
+ (let ([p (resolved-module-path-name
+ (module-path-index-resolve
+ (module-path-index-join (car libs) #f)))])
+ (if (path? p)
+ (intern-taglet (path->main-collects-relative p))
+ p))))
(define (id-to-target-maker id dep?)
(*id-to-target-maker 'def id dep?))
@@ -374,23 +373,22 @@
"no declared exporting libraries for definition"
id)))
(if e
- (let* ([lib-str (libs->str (exporting-libraries-libs e))]
+ (let* ([lib-taglet (libs->taglet (exporting-libraries-libs e))]
[tag (list (if sig
(case sym
[(def) 'sig-val]
[(form) 'sig-def])
sym)
- (format "~a::~a~a~a"
- lib-str
- (if sig (syntax-e (sig-id sig)) "")
- (if sig "::" "")
- (syntax-e id)))])
+ (append
+ (list lib-taglet)
+ (if sig (list (syntax-e (sig-id sig))) null)
+ (list (syntax-e id))))])
(if (or sig (not dep?))
(list (mk tag))
(list (make-target-element
#f
(list (mk tag))
- `(dep ,(format "~a::~a" lib-str (syntax-e id)))))))
+ `(dep ,(list lib-taglet (syntax-e id)))))))
content)))
(lambda () (car content))
(lambda () (car content))))))
@@ -405,9 +403,9 @@
(make-delayed-element
(lambda (renderer sec ri)
(let* ([tag (find-scheme-tag sec ri sig 'for-label)]
- [str (and tag (format "~a::~a" (cadr tag) elem))]
- [vtag (and tag `(sig-val ,str))]
- [stag (and tag `(sig-form ,str))]
+ [taglet (and tag (append (cadr tag) (list elem)))]
+ [vtag (and tag `(sig-val ,taglet))]
+ [stag (and tag `(sig-form ,taglet))]
[sd (and stag (resolve-get/tentative sec ri stag))])
(list
(make-element
@@ -466,7 +464,7 @@
(define (method-tag vtag sym)
(list 'meth
- (format "~a::~a" (cadr vtag) sym)))
+ (list (cadr vtag) sym)))
;; ----------------------------------------
@@ -1767,9 +1765,8 @@
(define (doc-prefix doc s)
(if doc
- (format "~a:~a"
- (module-path-prefix->string doc)
- s)
+ (list (module-path-prefix->string doc)
+ s)
s))
(define (secref s #:underline? [u? #t] #:doc [doc #f])
@@ -1956,7 +1953,7 @@
(let ([b (identifier-label-binding id)])
(list (let ([p (resolved-module-path-name (module-path-index-resolve (caddr b)))])
(if (path? p)
- (path->main-collects-relative p)
+ (intern-taglet (path->main-collects-relative p))
p))
(cadddr b)
(list-ref b 5))))
diff --git a/collects/scribble/scheme.ss b/collects/scribble/scheme.ss
@@ -182,9 +182,9 @@
(lambda (c)
(make-element "highlighted" (list c)))
values)
- (if color?
+ (if (and color? cls)
(make-element cls (list v))
- (make-element #f (list v))))
+ v))
content))
(set! dest-col (+ dest-col len))]))]))
(define advance
diff --git a/collects/scribble/search.ss b/collects/scribble/search.ss
@@ -4,7 +4,8 @@
setup/main-collects
syntax/modcode)
- (provide find-scheme-tag)
+ (provide find-scheme-tag
+ intern-taglet)
(define module-info-cache (make-hash-table))
@@ -17,6 +18,24 @@
(module-path-index-join name
(module-path-index-rejoin base rel-to))])))
+ (define interned (make-hash-table 'equal 'weak))
+
+ (define (intern-taglet v)
+ (let ([v (if (list? v)
+ (map intern-taglet v)
+ v)])
+ (if (or (string? v)
+ (bytes? v)
+ (list? v))
+ (let ([b (hash-table-get interned v #f)])
+ (if b
+ (weak-box-value b)
+ (begin
+ (hash-table-put! interned v (make-weak-box v))
+ v)))
+ v)))
+
+
;; mode is #f, 'for-label, or 'for-run
(define (find-scheme-tag part ri stx/binding mode)
(let ([b (cond
@@ -61,12 +80,11 @@
[queue (cdr queue)])
(let* ([rmp (module-path-index-resolve mod)]
[eb (and here?
- (format "~a::~a"
- (let ([p (resolved-module-path-name rmp)])
- (if (path? p)
- (path->main-collects-relative p)
- p))
- id))])
+ (list (let ([p (resolved-module-path-name rmp)])
+ (if (path? p)
+ (intern-taglet (path->main-collects-relative p))
+ p))
+ id))])
(when (and eb
(not search-key))
(set! search-key eb))
diff --git a/collects/scribble/struct.ss b/collects/scribble/struct.ss
@@ -124,7 +124,9 @@
(symbol? (car s))
(pair? (cdr s))
(or (string? (cadr s))
- (generated-tag? (cadr s)))
+ (generated-tag? (cadr s))
+ (and (pair? (cadr s))
+ (list? (cadr s))))
(null? (cddr s))))
(provide flow-element?)
@@ -356,9 +358,9 @@
(list (car tg)
(let ([tags (collect-info-tags ci)])
(or (hash-table-get tags t #f)
- (let ([key (format "gentag:~a~a"
- (collect-info-gen-prefix ci)
- (hash-table-count tags))])
+ (let ([key (list* 'gentag
+ (hash-table-count tags)
+ (collect-info-gen-prefix ci))])
(hash-table-put! tags t key)
key)))))
tg))
@@ -406,8 +408,12 @@
[(and (link-element? c)
(null? (element-content c)))
(let ([dest (resolve-get sec ri (link-element-tag c))])
+ ;; FIXME: this is specific to renderer
(if dest
- (content->string (strip-aux (cadr dest)) renderer sec ri)
+ (content->string (strip-aux (if (pair? dest)
+ (cadr dest)
+ (vector-ref dest 1)))
+ renderer sec ri)
"???"))]
[(element? c) (content->string (element-content c) renderer sec ri)]
[(delayed-element? c)
diff --git a/collects/scribblings/scribble/struct.scrbl b/collects/scribblings/scribble/struct.scrbl
@@ -551,13 +551,23 @@ only during the @techlink{collect pass}.
}
-@defproc[(resolve-get [ri resolve-info?] [key any/c])
+@defproc[(resolve-get [p part?] [ri resolve-info?] [key any/c])
void?]{
Extract information during the @techlink{resolve pass} or
-@techlink{render pass} from @scheme[ri], where the information was
-previously registered during the @techlink{collect pass}. See also
-@secref["passes"].
+@techlink{render pass} for @scheme[p] from @scheme[ri], where the
+information was previously registered during the @techlink{collect
+pass}. See also @secref["passes"].
+
+}
+
+@defproc[(resolve-get-keys [p part?] [ri resolve-info?]
+ [pred (any/c . -> . any/c)])
+ list?]{
+
+Applies @scheme[pred] to each key mapped for @scheme[p] in
+@scheme[ri], returning a list of all keys for which @scheme[pred]
+returns a true value.
}
