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

small improvements to scribble data structures

Browse Source 
svn: r8481

original commit: 7e6ef8eeb5bbd071ac41675fdd23246b928eedac
This commit is contained in:
Matthew Flatt 2008-01-31 00:06:54 +00:00
parent 1ca010cfb2
commit e192679a2b
8 changed files with 128 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/scribble/base-render.ss
View File

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

4
collects/scribble/basic.ss
View File

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

61
collects/scribble/html-render.ss
View File

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

43
collects/scribble/manual.ss
View File

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

4
collects/scribble/scheme.ss
View File

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

32
collects/scribble/search.ss
View File

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

16
collects/scribble/struct.ss
View File

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

18
collects/scribblings/scribble/struct.scrbl
View File

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