commit aee87f3568df9713782673741244692554c65e3a
parent 7de01e897e8e7eff87f59aafb5a888cdc04814fe
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Thu, 3 Jan 2008 19:07:02 +0000
3.99.0.9: binding links in docs use nominal import sources
svn: r8196
original commit: 7fc41024c0f09d03bed22c9e68bc2548f9222b77
Diffstat:
18 files changed, 722 insertions(+), 372 deletions(-)
diff --git a/collects/scribble/base-render.ss b/collects/scribble/base-render.ss
@@ -4,7 +4,8 @@
mzlib/class
mzlib/serialize
scheme/file
- scheme/path)
+ scheme/path
+ setup/main-collects)
(provide render%)
@@ -74,7 +75,9 @@
(make-hash-table 'equal)
(make-hash-table)
(make-hash-table)
- "")])
+ ""
+ (make-hash-table)
+ null)])
(start-collect ds fns ci)
ci))
@@ -92,7 +95,9 @@
(string-append (collect-info-gen-prefix ci)
(part-tag-prefix d)
":")
- (collect-info-gen-prefix ci)))])
+ (collect-info-gen-prefix ci))
+ (collect-info-relatives ci)
+ (cons d (collect-info-parents ci)))])
(when (part-title-content d)
(collect-content (part-title-content d) p-ci))
(collect-part-tags d p-ci number)
@@ -184,16 +189,28 @@
(blockquote-paragraphs i)))
(define/public (collect-element i ci)
- (when (target-element? i)
- (collect-target-element i ci))
- (when (index-element? i)
- (collect-index-element i ci))
- (when (collect-element? i)
- ((collect-element-collect i) ci))
- (when (element? i)
- (for-each (lambda (e)
- (collect-element e ci))
- (element-content i))))
+ (if (part-relative-element? i)
+ (let ([content
+ (or (hash-table-get (collect-info-relatives ci)
+ i
+ #f)
+ (let ([v ((part-relative-element-collect i) ci)])
+ (hash-table-put! (collect-info-relatives ci)
+ i
+ v)
+ v))])
+ (collect-content content ci))
+ (begin
+ (when (target-element? i)
+ (collect-target-element i ci))
+ (when (index-element? i)
+ (collect-index-element i ci))
+ (when (collect-element? i)
+ ((collect-element-collect i) ci))
+ (when (element? i)
+ (for-each (lambda (e)
+ (collect-element e ci))
+ (element-content i))))))
(define/public (collect-target-element i ci)
(collect-put! ci
@@ -213,6 +230,7 @@
(define/public (resolve ds fns ci)
(let ([ri (make-resolve-info ci
(make-hash-table)
+ (make-hash-table 'equal)
(make-hash-table 'equal))])
(start-resolve ds fns ri)
ri))
@@ -269,6 +287,8 @@
(define/public (resolve-element i d ri)
(cond
+ [(part-relative-element? i)
+ (resolve-content (part-relative-element-content i ri) d ri)]
[(delayed-element? i)
(resolve-content (or (hash-table-get (resolve-info-delays ri)
i
@@ -372,6 +392,8 @@
(render-content (element-content i) part ri)]
[(delayed-element? i)
(render-content (delayed-element-content i ri) part ri)]
+ [(part-relative-element? i)
+ (render-content (part-relative-element-content i ri) part ri)]
[else
(render-other i part ri)]))
diff --git a/collects/scribble/basic.ss b/collects/scribble/basic.ss
@@ -47,20 +47,20 @@
style
content)))
- (define (subsection #:tag [tag #f] #:tag-prefix [prefix #f] . str)
+ (define (subsection #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style #f] . str)
(let ([content (decode-content str)])
(make-part-start 1
(prefix->string prefix)
(convert-tag tag content)
- #f
+ style
content)))
- (define (subsubsection #:tag [tag #f] #:tag-prefix [prefix #f] . str)
+ (define (subsubsection #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style #f] . str)
(let ([content (decode-content str)])
(make-part-start 2
(prefix->string prefix)
(convert-tag tag content)
- #f
+ style
content)))
(define (subsubsub*section #:tag [tag #f] . str)
diff --git a/collects/scribble/decode.ss b/collects/scribble/decode.ss
@@ -27,7 +27,8 @@
[splice ([run list?])]
[part-index-decl ([plain-seq (listof string?)]
[entry-seq list?])]
- [part-collect-decl ([element element?])]
+ [part-collect-decl ([element (or/c element?
+ part-relative-element?)])]
[part-tag-decl ([tag tag?])])
(define (decode-string s)
diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss
@@ -251,8 +251,11 @@
(append (loop (element-content a))
(loop (cdr c)))]
[(delayed-element? a)
- (loop (cons (delayed-element-content a ri)
- (cdr c)))]
+ (loop (append (delayed-element-content a ri)
+ (cdr c)))]
+ [(part-relative-element? a)
+ (loop (append (part-relative-element-content a ri)
+ (cdr c)))]
[else
(loop (cdr c))]))])))]
[table-targets
diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss
@@ -3,6 +3,7 @@
(require "decode.ss"
"struct.ss"
"scheme.ss"
+ "search.ss"
"config.ss"
"basic.ss"
"manual-struct.ss"
@@ -10,6 +11,7 @@
scheme/class
scheme/stxparam
mzlib/serialize
+ setup/main-collects
(for-syntax scheme/base)
(for-label scheme/base
scheme/class))
@@ -309,34 +311,74 @@
;; ----------------------------------------
- (define-struct sig (tagstr))
+ (define (gen-absolute-tag)
+ `(abs ,(make-generated-tag)))
+
+ (define-struct sig (id))
(define (definition-site name stx-id form?)
(let ([sig (current-signature)])
(if sig
- (make-link-element (if form?
- "schemesyntaxlink"
- "schemevaluelink")
- (list (schemefont (symbol->string name)))
- `(,(if form? 'sig-form 'sig-val)
- ,(format "~a::~a" (sig-tagstr sig) name)))
+ (*sig-elem (sig-id sig) name)
(annote-exporting-library
(to-element (make-just-context name stx-id))))))
- (define (id-to-tag id)
- (add-signature-tag id #f))
-
- (define (id-to-form-tag id)
- (add-signature-tag id #t))
-
- (define (add-signature-tag id form?)
+ (define (libs->str 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)))))
+
+ (define (id-to-target-maker id dep?)
+ (*id-to-target-maker 'def id dep?))
+
+ (define (id-to-form-target-maker id dep?)
+ (*id-to-target-maker 'form id dep?))
+
+ (define (*id-to-target-maker sym id dep?)
(let ([sig (current-signature)])
- (if sig
- `(,(if form? 'sig-form 'sig-val)
- ,(format "~a::~a" (sig-tagstr sig) (syntax-e id)))
- (if form?
- (register-scheme-form-definition id)
- (register-scheme-definition id #t)))))
+ (lambda (content mk)
+ (make-part-relative-element
+ (lambda (ci)
+ (let ([e (ormap (lambda (p)
+ (ormap (lambda (e)
+ (and (exporting-libraries? e) e))
+ (part-to-collect p)))
+ (collect-info-parents ci))])
+ (unless e
+ ;; Call raise-syntax-error to capture error message:
+ (with-handlers ([exn:fail:syntax? (lambda (exn)
+ (fprintf (current-error-port)
+ "~a\n"
+ (exn-message exn)))])
+ (raise-syntax-error 'WARNING
+ "no declared exporting libraries for definition"
+ id)))
+ (if e
+ (let* ([lib-str (libs->str (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)))])
+ (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)))))))
+ content)))
+ (lambda () (car content))
+ (lambda () (car content))))))
(define current-signature (make-parameter #f))
@@ -344,21 +386,25 @@
(*sig-elem (quote-syntax sig) 'elem))
(define (*sig-elem sig elem)
- (let ([s (to-element elem)]
- [tag (format "~a::~a"
- (register-scheme-form-definition sig #t)
- elem)])
+ (let ([s (to-element/no-color elem)])
(make-delayed-element
(lambda (renderer sec ri)
- (let* ([vtag `(sig-val ,tag)]
- [stag `(sig-form ,tag)]
- [sd (resolve-get/tentative sec ri stag)])
+ (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))]
+ [sd (and stag (resolve-get/tentative sec ri stag))])
(list
- (cond
- [sd
- (make-link-element "schemesyntaxlink" (list s) stag)]
- [else
- (make-link-element "schemevaluelink" (list s) vtag)]))))
+ (make-element
+ "schemesymbol"
+ (list
+ (cond
+ [sd
+ (make-link-element "schemesyntaxlink" (list s) stag)]
+ [vtag
+ (make-link-element "schemevaluelink" (list s) vtag)]
+ [else
+ s]))))))
(lambda () s)
(lambda () s))))
@@ -379,15 +425,29 @@
(elem (method a b) " in " (scheme a))]))
(define (*method sym id)
- (**method sym (id-to-tag id)))
-
- (define (**method sym tag)
- (make-element
- "schemesymbol"
- (list (make-link-element
- "schemevaluelink"
- (list (symbol->string sym))
- (method-tag tag sym)))))
+ (**method sym id))
+
+ (define (**method sym id/tag)
+ (let ([content (list (symbol->string sym))])
+ ((if (identifier? id/tag)
+ (lambda (c mk)
+ (make-delayed-element
+ (lambda (ren p ri)
+ (let ([tag (find-scheme-tag p ri id/tag 'for-label)])
+ (if tag
+ (list (mk tag))
+ content)))
+ (lambda () (car content))
+ (lambda () (car content))))
+ (lambda (c mk) (mk id/tag)))
+ content
+ (lambda (tag)
+ (make-element
+ "schemesymbol"
+ (list (make-link-element
+ "schemevaluelink"
+ content
+ (method-tag tag sym))))))))
(define (method-tag vtag sym)
(list 'meth
@@ -458,12 +518,18 @@
(syntax-rules ()
[(_ lib ...) (*declare-exporting '(lib ...))]))
+ (define-struct (exporting-libraries element) (libs))
+
(define (*declare-exporting libs)
- (make-part-collect-decl
- (make-collect-element #f
- null
- (lambda (ri)
- (collect-put! ri '(exporting-libraries #f)libs)))))
+ (make-splice
+ (list
+ (make-part-collect-decl
+ (make-collect-element #f
+ null
+ (lambda (ri)
+ (collect-put! ri '(exporting-libraries #f) libs))))
+ (make-part-collect-decl
+ (make-exporting-libraries #f null libs)))))
(define-syntax (quote-syntax/loc stx)
(syntax-case stx ()
@@ -1016,45 +1082,51 @@
(hspace 1)
(if first?
(let* ([mname (extract-id prototype)]
- [ctag (id-to-tag within-id)]
- [tag (method-tag ctag mname)]
+ [target-maker (id-to-target-maker within-id #f)]
[content (list (*method mname within-id))])
- (if tag
- (make-toc-target-element
- #f
- (list (make-index-element #f
- content
- tag
- (list (symbol->string mname))
- content
- (with-exporting-libraries
- (lambda (libs)
- (make-method-index-desc
- (syntax-e within-id)
- libs
- mname
- ctag)))))
- tag)
+ (if target-maker
+ (target-maker
+ content
+ (lambda (ctag)
+ (let ([tag (method-tag ctag mname)])
+ (make-toc-target-element
+ #f
+ (list (make-index-element #f
+ content
+ tag
+ (list (symbol->string mname))
+ content
+ (with-exporting-libraries
+ (lambda (libs)
+ (make-method-index-desc
+ (syntax-e within-id)
+ libs
+ mname
+ ctag)))))
+ tag))))
(car content)))
(*method (extract-id prototype) within-id))))]
[else
(if first?
- (let ([tag (id-to-tag stx-id)]
+ (let ([target-maker (id-to-target-maker stx-id #t)]
[content (list (definition-site (extract-id prototype) stx-id #f))])
- (if tag
- (make-toc-target-element
- #f
- (list (make-index-element #f
- content
- tag
- (list (symbol->string (extract-id prototype)))
- content
- (with-exporting-libraries
- (lambda (libs)
- (make-procedure-index-desc
- (extract-id prototype)
- libs)))))
- tag)
+ (if target-maker
+ (target-maker
+ content
+ (lambda (tag)
+ (make-toc-target-element
+ #f
+ (list (make-index-element #f
+ content
+ tag
+ (list (symbol->string (extract-id prototype)))
+ content
+ (with-exporting-libraries
+ (lambda (libs)
+ (make-procedure-index-desc
+ (extract-id prototype)
+ libs)))))
+ tag)))
(car content)))
(annote-exporting-library
(to-element (make-just-context (extract-id prototype)
@@ -1241,27 +1313,31 @@
(let* ([name
(apply string-append
(map symbol->string (cdar wrappers)))]
- [tag
- (id-to-tag
+ [target-maker
+ (id-to-target-maker
(datum->syntax stx-id
(string->symbol
- name)))])
- (if tag
- (inner-make-target-element
- #f
- (list
- (make-index-element #f
- (list content)
- tag
- (list name)
- (list (schemeidfont (make-element "schemevaluelink" (list name))))
- (with-exporting-libraries
- (lambda (libs)
- (let ([name (string->symbol name)])
- (if (eq? 'info (caar wrappers))
- (make-struct-index-desc name libs)
- (make-procedure-index-desc name libs)))))))
- tag)
+ name))
+ #t)])
+ (if target-maker
+ (target-maker
+ (list content)
+ (lambda (tag)
+ (inner-make-target-element
+ #f
+ (list
+ (make-index-element #f
+ (list content)
+ tag
+ (list name)
+ (list (schemeidfont (make-element "schemevaluelink" (list name))))
+ (with-exporting-libraries
+ (lambda (libs)
+ (let ([name (string->symbol name)])
+ (if (eq? 'info (caar wrappers))
+ (make-struct-index-desc name libs)
+ (make-procedure-index-desc name libs)))))))
+ tag)))
content))
(cdr wrappers))))
@@ -1454,20 +1530,24 @@
(list (make-flow
(list
(make-paragraph
- (list (let ([tag ((if form? id-to-form-tag id-to-tag) stx-id)]
+ (list (let ([target-maker ((if form? id-to-form-target-maker id-to-target-maker) stx-id #t)]
[content (list (definition-site name stx-id form?))])
- (if tag
- (make-toc-target-element
- #f
- (list (make-index-element #f
- content
- tag
- (list (symbol->string name))
- content
- (with-exporting-libraries
- (lambda (libs)
- (make-thing-index-desc name libs)))))
- tag)
+ (if target-maker
+ (target-maker
+ content
+ (lambda (tag)
+ (make-toc-target-element
+ #f
+ (list
+ (make-index-element #f
+ content
+ tag
+ (list (symbol->string name))
+ content
+ (with-exporting-libraries
+ (lambda (libs)
+ (make-thing-index-desc name libs)))))
+ tag)))
(car content)))
spacer ":" spacer))))
(make-flow
@@ -1520,31 +1600,29 @@
`(,x . ,(cdr form)))))))
(and kw-id
(eq? form (car forms))
- (let ([tag (id-to-tag kw-id)]
- [stag (id-to-form-tag kw-id)]
+ (let ([target-maker (id-to-form-target-maker kw-id #t)]
[content (list (definition-site (if (pair? form)
(car form)
form)
kw-id
#t))])
- (if tag
- (make-target-element
- #f
- (list
- (make-toc-target-element
- #f
- (if kw-id
- (list (make-index-element #f
- content
- tag
- (list (symbol->string (syntax-e kw-id)))
- content
- (with-exporting-libraries
- (lambda (libs)
- (make-form-index-desc (syntax-e kw-id) libs)))))
- content)
- stag))
- tag)
+ (if target-maker
+ (target-maker
+ content
+ (lambda (tag)
+ (make-toc-target-element
+ #f
+ (if kw-id
+ (list (make-index-element #f
+ content
+ tag
+ (list (symbol->string (syntax-e kw-id)))
+ content
+ (with-exporting-libraries
+ (lambda (libs)
+ (make-form-index-desc (syntax-e kw-id) libs)))))
+ content)
+ tag)))
(car content)))))))))
forms form-procs)
(if (null? sub-procs)
@@ -1680,9 +1758,19 @@
(make-link-element (if u? #f "plainlink") null `(part ,(doc-prefix doc s))))
(define (seclink tag #:underline? [u? #t] #:doc [doc #f] . s)
(make-link-element (if u? #f "plainlink") (decode-content s) `(part ,(doc-prefix doc tag))))
+
(define (*schemelink stx-id id . s)
- (make-link-element #f (decode-content s) (or (register-scheme-definition stx-id)
- (format "--UNDEFINED:~a--" (syntax-e stx-id)))))
+ (let ([content (decode-content s)])
+ (make-delayed-element
+ (lambda (r p ri)
+ (list
+ (make-link-element #f
+ content
+ (or (find-scheme-tag p ri stx-id 'for-label)
+ (format "--UNDEFINED:~a--" (syntax-e stx-id))))))
+ (lambda () content)
+ (lambda () content))))
+
(define-syntax schemelink
(syntax-rules ()
[(_ id . content) (*schemelink (quote-syntax id) 'id . content)]))
@@ -1841,28 +1929,45 @@
(define-struct spec (def))
(define-struct impl (def))
+ (define (id-info id)
+ (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)
+ p))
+ (cadddr b)
+ (list-ref b 5))))
+
(define-serializable-struct cls/intf (name-element super intfs methods))
(define (make-inherited-table r d ri decl)
- (let* ([start (let ([key (register-scheme-definition (decl-name decl))])
- (list (cons key (lookup-cls/intf d ri key))))]
- [supers (cdr
- (let loop ([supers start][accum null])
- (cond
- [(null? supers) (reverse accum)]
- [(memq (car supers) accum)
- (loop (cdr supers) accum)]
- [else
- (let ([super (car supers)])
- (loop (append (map (lambda (i)
- (cons i (lookup-cls/intf d ri i)))
- (reverse (cls/intf-intfs (cdr super))))
- (let ([s (cls/intf-super (cdr super))])
- (if s
- (list (cons s (lookup-cls/intf d ri s)))
- null))
- (cdr supers))
- (cons super accum)))])))]
+ (let* ([start (let ([key (find-scheme-tag d ri (decl-name decl) 'for-label)])
+ (if key
+ (list (cons key (lookup-cls/intf d ri key)))
+ null))]
+ [supers (if (null? start)
+ null
+ (cdr
+ (let loop ([supers start][accum null])
+ (cond
+ [(null? supers) (reverse accum)]
+ [(memq (car supers) accum)
+ (loop (cdr supers) accum)]
+ [else
+ (let ([super (car supers)])
+ (loop (append (filter values
+ (map (lambda (i)
+ (let ([key (find-scheme-tag d ri i 'for-label)])
+ (and key
+ (cons key (lookup-cls/intf d ri key)))))
+ (reverse (cls/intf-intfs (cdr super)))))
+ (let ([s (and (cls/intf-super (cdr super))
+ (find-scheme-tag d ri (cls/intf-super (cdr super)) 'for-label))])
+ (if s
+ (list (cons s (lookup-cls/intf d ri s)))
+ null))
+ (cdr supers))
+ (cons super accum)))]))))]
[ht (let ([ht (make-hash-table)])
(for-each (lambda (i)
(when (meth? i)
@@ -1902,27 +2007,29 @@
(define (make-decl-collect decl)
(make-part-collect-decl
- (make-collect-element
- #f null
- (lambda (ci)
- (let ([tag (register-scheme-definition (decl-name decl))])
- (collect-put! ci
- `(cls/intf ,tag)
- (make-cls/intf
- (make-element
- "schemesymbol"
- (list (make-link-element
- "schemevaluelink"
- (list (symbol->string (syntax-e (decl-name decl))))
- tag)))
- (and (decl-super decl)
- (not (free-label-identifier=? (quote-syntax object%)
- (decl-super decl)))
- (register-scheme-definition (decl-super decl)))
- (map register-scheme-definition (decl-intfs decl))
- (map (lambda (m)
- (meth-name m))
- (filter meth? (decl-body decl))))))))))
+ ((id-to-target-maker (decl-name decl) #f)
+ (list "ignored")
+ (lambda (tag)
+ (make-collect-element
+ #f null
+ (lambda (ci)
+ (collect-put! ci
+ `(cls/intf ,(cadr tag))
+ (make-cls/intf
+ (make-element
+ "schemesymbol"
+ (list (make-link-element
+ "schemevaluelink"
+ (list (symbol->string (syntax-e (decl-name decl))))
+ tag)))
+ (and (decl-super decl)
+ (not (free-label-identifier=? (quote-syntax object%)
+ (decl-super decl)))
+ (id-info (decl-super decl)))
+ (map id-info (decl-intfs decl))
+ (map (lambda (m)
+ (meth-name m))
+ (filter meth? (decl-body decl)))))))))))
(define (build-body decl body)
(append
@@ -1969,22 +2076,26 @@
(list (make-flow
(list
(make-paragraph
- (list (let ([tag (id-to-tag stx-id)]
+ (list (let ([target-maker (id-to-target-maker stx-id #t)]
[content (list (annote-exporting-library (to-element stx-id)))])
- (if tag
- ((if whole-page?
- make-page-target-element
- make-toc-target-element)
- #f
- (list (make-index-element #f
- content
- tag
- (list (symbol->string (syntax-e stx-id)))
- content
- (with-exporting-libraries
- (lambda (libs)
- (make-index-desc (syntax-e stx-id) libs)))))
- tag)
+ (if target-maker
+ (target-maker
+ content
+ (lambda (tag)
+ ((if whole-page?
+ make-page-target-element
+ make-toc-target-element)
+ #f
+ (list
+ (make-index-element #f
+ content
+ tag
+ (list (symbol->string (syntax-e stx-id)))
+ content
+ (with-exporting-libraries
+ (lambda (libs)
+ (make-index-desc (syntax-e stx-id) libs)))))
+ tag)))
(car content)))
spacer ":" spacer
(case kind
@@ -2222,36 +2333,38 @@
(define (*xmethod/super cname name)
(let ([get
(lambda (d ri key)
- (let ([v (lookup-cls/intf d ri key)])
- (if v
- (cons (cls/intf-super v)
- (cls/intf-intfs v))
- null)))]
- [ctag (id-to-tag cname)])
+ (if key
+ (let ([v (lookup-cls/intf d ri key)])
+ (if v
+ (cons (cls/intf-super v)
+ (cls/intf-intfs v))
+ null))
+ null))])
(make-delayed-element
(lambda (r d ri)
- (let loop ([search (get d ri ctag)])
+ (let loop ([search (get d ri (find-scheme-tag d ri cname 'for-label))])
(cond
[(null? search)
(list (make-element #f '("<method not found>")))]
[(not (car search))
(loop (cdr search))]
[else
- (let ([v (lookup-cls/intf d ri (car search))])
+ (let* ([a-key (find-scheme-tag d ri (car search) 'for-label)]
+ [v (and a-key (lookup-cls/intf d ri a-key))])
(if v
(if (member name (cls/intf-methods v))
(list
(make-element #f
- (list (**method name (car search))
+ (list (**method name a-key)
" in "
(cls/intf-name-element v))))
- (loop (append (cdr search) (get d ri (car search)))))
+ (loop (append (cdr search) (get d ri (find-scheme-tag d ri (car search) 'for-label)))))
(loop (cdr search))))])))
(lambda () (format "~a in ~a" (syntax-e cname) name))
(lambda () (format "~a in ~a" (syntax-e cname) name)))))
- (define (lookup-cls/intf d ri name)
- (let ([v (resolve-get d ri `(cls/intf ,name))])
+ (define (lookup-cls/intf d ri tag)
+ (let ([v (resolve-get d ri `(cls/intf ,(cadr tag)))])
(or v
(make-cls/intf "unknown"
#f
@@ -2294,8 +2407,7 @@
#t
(list (make-element #f '("signature")))
(lambda ()
- (let ([in (parameterize ([current-signature (make-sig
- (id-to-form-tag stx-id))])
+ (let ([in (parameterize ([current-signature (make-sig stx-id)])
(body-thunk))])
(if indent?
(let-values ([(pre-body post-body)
diff --git a/collects/scribble/scheme.ss b/collects/scribble/scheme.ss
@@ -1,10 +1,12 @@
(module scheme scheme/base
(require "struct.ss"
"basic.ss"
+ "search.ss"
mzlib/class
mzlib/for
setup/main-collects
syntax/modresolve
+ syntax/modcode
(for-syntax scheme/base))
(provide define-code
@@ -12,8 +14,6 @@
to-element/no-color
to-paragraph
to-paragraph/prefix
- register-scheme-definition
- register-scheme-form-definition
syntax-ize
syntax-ize-hook
current-keyword-list
@@ -73,28 +73,30 @@
(values (substring s 1) #t #f)
(values s #f #f))))])
(if (or (element? (syntax-e c))
- (delayed-element? (syntax-e c)))
+ (delayed-element? (syntax-e c))
+ (part-relative-element? (syntax-e c)))
(out (syntax-e c) #f)
(out (if (and (identifier? c)
color?
(quote-depth . <= . 0)
(not (or it? is-var?)))
- (let ([tag (register-scheme c)])
- (if tag
- (make-delayed-element
- (lambda (renderer sec ri)
- (let* ([vtag `(def ,tag)]
- [stag `(form ,tag)]
- [sd (resolve-get/tentative sec ri stag)])
- (list
- (cond
- [sd
- (make-link-element "schemesyntaxlink" (list s) stag)]
- [else
- (make-link-element "schemevaluelink" (list s) vtag)]))))
- (lambda () s)
- (lambda () s))
- s))
+ (if (pair? (identifier-label-binding c))
+ (make-delayed-element
+ (lambda (renderer sec ri)
+ (let* ([tag (find-scheme-tag sec ri c 'for-label)])
+ (if tag
+ (list
+ (case (car tag)
+ [(form)
+ (make-link-element "schemesyntaxlink" (list s) tag)]
+ [else
+ (make-link-element "schemevaluelink" (list s) tag)]))
+ (list
+ (make-element "badlink"
+ (list (make-element "schemevaluelink" (list s))))))))
+ (lambda () s)
+ (lambda () s))
+ s)
(literalize-spaces s))
(cond
[(positive? quote-depth) value-color]
@@ -155,6 +157,8 @@
(element-width v)]
[(delayed-element? v)
(element-width v)]
+ [(part-relative-element? v)
+ (element-width v)]
[(spaces? v)
(+ (sz-loop (car (element-content v)))
(spaces-cnt v)
@@ -538,41 +542,6 @@
[(_ code typeset-code) #'(define-code code typeset-code unsyntax)]))
- (define (register-scheme stx [warn-if-no-label? #f])
- (unless (identifier? stx)
- (error 'register-scheme-definition "not an identifier: ~e" (syntax->datum stx)))
- (let ([b (identifier-label-binding stx)])
- (if (or (not b)
- (eq? b 'lexical))
- (if warn-if-no-label?
- (begin
- (fprintf (current-error-port)
- "~a\n"
- ;; Call raise-syntax-error to capture error message:
- (with-handlers ([exn:fail:syntax? (lambda (exn)
- (exn-message exn))])
- (raise-syntax-error 'WARNING
- "no for-label binding of identifier"
- stx)))
- (format ":NOLABEL:~a" (syntax-e stx)))
- #f)
- (format ":~a:~a"
- (let ([p (resolve-module-path-index (car b) #f)])
- (if (path? p)
- (path->main-collects-relative p)
- p))
- (cadr b)))))
-
- (define (register-scheme/invent stx warn-if-no-label?)
- (or (register-scheme stx warn-if-no-label?)
- (format ":UNKNOWN:~a" (syntax-e stx))))
-
- (define (register-scheme-definition stx [warn-if-no-label? #f])
- `(def ,(register-scheme/invent stx warn-if-no-label?)))
-
- (define (register-scheme-form-definition stx [warn-if-no-label? #f])
- `(form ,(register-scheme/invent stx warn-if-no-label?)))
-
(define syntax-ize-hook (make-parameter (lambda (v col) #f)))
(define (vector->short-list v extract)
diff --git a/collects/scribble/search.ss b/collects/scribble/search.ss
@@ -0,0 +1,126 @@
+(module search scheme/base
+ (require "struct.ss"
+ "basic.ss"
+ setup/main-collects
+ syntax/modcode)
+
+ (provide find-scheme-tag)
+
+ (define module-info-cache (make-hash-table))
+
+ (define (module-path-index-rejoin mpi rel-to)
+ (let-values ([(name base) (module-path-index-split mpi)])
+ (cond
+ [(not name) rel-to]
+ [(not base) mpi]
+ [else
+ (module-path-index-join name
+ (module-path-index-rejoin base rel-to))])))
+
+ ;; mode is #f, 'for-label, or 'for-run
+ (define (find-scheme-tag part ri stx/binding mode)
+ (let ([b (cond
+ [(identifier? stx/binding)
+ ((case mode
+ [(for-label) identifier-label-binding]
+ [(for-syntax) identifier-transformer-binding]
+ [else identifier-binding])
+ stx/binding)]
+ [(and (list? stx/binding)
+ (= 6 (length stx/binding)))
+ stx/binding]
+ [else
+ (and (not (symbol? (car stx/binding)))
+ (let ([p (module-path-index-join
+ (main-collects-relative->path (car stx/binding))
+ #f)])
+ (list #f
+ (cadr stx/binding)
+ p
+ (cadr stx/binding)
+ #f
+ (if (= 2 (length stx/binding))
+ mode
+ (caddr stx/binding)))))])])
+ (and
+ (pair? b)
+ (let ([seen (make-hash-table)]
+ [search-key #f])
+ (let loop ([queue (list (list (caddr b) (cadddr b) (eq? mode (list-ref b 5))))]
+ [rqueue null])
+ (cond
+ [(null? queue)
+ (if (null? rqueue)
+ ;; Not documented
+ #f
+ (loop (reverse rqueue) null))]
+ [else
+ (let ([mod (caar queue)]
+ [id (cadar queue)]
+ [here? (caddar queue)]
+ [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))])
+ (when (and eb
+ (not search-key))
+ (set! search-key eb))
+ (let ([v (and eb (resolve-search search-key part ri `(dep ,eb)))])
+ (or (and v
+ (let ([v (resolve-get/tentative part ri `(form ,eb))])
+ (or (and v `(form ,eb))
+ `(def ,eb))))
+ ;; Maybe it's re-exported from this module...
+ ;; Try a shortcut:
+ (if (eq? rmp (and (car b) (module-path-index-resolve (car b))))
+ ;; Not defined through this path, so keep looking
+ (loop queue rqueue)
+ ;; Check parents, if we can get the source:
+ (if (and (path? (resolved-module-path-name rmp))
+ (not (hash-table-get seen rmp #f)))
+ (let ([exports
+ (hash-table-get
+ module-info-cache
+ rmp
+ (lambda ()
+ (let-values ([(run-vals run-stxes
+ syntax-vals syntax-stxes
+ label-vals label-stxes)
+ (module-compiled-exports
+ (get-module-code (resolved-module-path-name rmp)))])
+ (let ([t (list (append run-vals run-stxes)
+ (append syntax-vals syntax-stxes)
+ (append label-vals label-stxes))])
+ (hash-table-put! module-info-cache rmp t)
+ t))))])
+ (hash-table-put! seen rmp #t)
+ (let ([a (assq id (list-ref exports
+ (if here?
+ 0
+ (case mode
+ [(for-syntax) 1]
+ [(for-label) 2]
+ [else 0]))))])
+ (if a
+ (loop queue
+ (append (map (lambda (m)
+ (if (pair? m)
+ (list (module-path-index-rejoin (car m) mod)
+ (caddr m)
+ (or here?
+ (eq? mode (cadr m))))
+ (list (module-path-index-rejoin m mod)
+ id
+ here?)))
+ (cadr a))
+ rqueue))
+ (error 'find-scheme-tag
+ "dead end when looking for binding source: ~e"
+ id))))
+ ;; Can't get the module source, so continue with queue:
+ (loop queue rqueue)))))))])))))))
+\ No newline at end of file
diff --git a/collects/scribble/struct.ss b/collects/scribble/struct.ss
@@ -6,8 +6,8 @@
;; ----------------------------------------
- (define-struct collect-info (ht ext-ht parts tags gen-prefix))
- (define-struct resolve-info (ci delays undef))
+ (define-struct collect-info (ht ext-ht parts tags gen-prefix relatives parents))
+ (define-struct resolve-info (ci delays undef searches))
(define (part-collected-info part ri)
(hash-table-get (collect-info-parts (resolve-info-ci ri))
@@ -49,6 +49,18 @@
#t))
v))
+ (define (resolve-search search-key part ri key)
+ (let ([s-ht (hash-table-get (resolve-info-searches ri)
+ search-key
+ (lambda ()
+ (let ([s-ht (make-hash-table 'equal)])
+ (hash-table-put! (resolve-info-searches ri)
+ search-key
+ s-ht)
+ s-ht)))])
+ (hash-table-put! s-ht key #t))
+ (resolve-get part ri key))
+
(define (resolve-get/tentative part ri key)
(let-values ([(v ext?) (resolve-get/where part ri key)])
v))
@@ -69,6 +81,7 @@
part-collected-info
collect-put!
resolve-get
+ resolve-search
resolve-get/tentative
resolve-get-keys)
@@ -163,12 +176,11 @@
[target-url ([addr string?])]
[image-file ([path path-string?])])
-
+
;; ----------------------------------------
;; Delayed element has special serialization support:
(define-struct delayed-element (resolve sizer plain)
- #:mutable
#:property
prop:serializable
(make-serialize-info
@@ -210,6 +222,47 @@
;; ----------------------------------------
+ ;; part-relative element has special serialization support:
+ (define-struct part-relative-element (collect sizer plain)
+ #:property
+ prop:serializable
+ (make-serialize-info
+ (lambda (d)
+ (let ([ri (current-serialize-resolve-info)])
+ (unless ri
+ (error 'serialize-part-relative-element
+ "current-serialize-resolve-info not set"))
+ (with-handlers ([exn:fail:contract?
+ (lambda (exn)
+ (error 'serialize-part-relative-element
+ "serialization failed (wrong resolve info?); ~a"
+ (exn-message exn)))])
+ (vector
+ (make-element #f (part-relative-element-content d ri))))))
+ #'deserialize-part-relative-element
+ #f
+ (or (current-load-relative-directory) (current-directory))))
+
+ (provide/contract
+ (struct part-relative-element ([collect (collect-info? . -> . list?)]
+ [sizer (-> any)]
+ [plain (-> any)])))
+
+ (provide deserialize-part-relative-element)
+ (define deserialize-part-relative-element
+ (make-deserialize-info values values))
+
+ (provide part-relative-element-content)
+ (define (part-relative-element-content e ci/ri)
+ (hash-table-get (collect-info-relatives (if (resolve-info? ci/ri)
+ (resolve-info-ci ci/ri)
+ ci/ri))
+ e))
+
+ (provide collect-info-parents)
+
+ ;; ----------------------------------------
+
;; Delayed index entry also has special serialization support.
;; It uses the same delay -> value table as delayed-element
(define-struct delayed-index-desc (resolve)
@@ -336,6 +389,7 @@
[(c)
(cond
[(element? c) (content->string (element-content c))]
+ [(part-relative-element? c) (element->string ((part-relative-element-plain c)))]
[(delayed-element? c) (element->string ((delayed-element-plain c)))]
[(string? c) c]
[else (case c
@@ -356,6 +410,9 @@
[(delayed-element? c)
(content->string (delayed-element-content c ri)
renderer sec ri)]
+ [(part-relative-element? c)
+ (content->string (part-relative-element-content c ri)
+ renderer sec ri)]
[else (element->string c)])]))
(define (strip-aux content)
@@ -376,6 +433,7 @@
[(string? s) (string-length s)]
[(element? s) (apply + (map element-width (element-content s)))]
[(delayed-element? s) (element-width ((delayed-element-sizer s)))]
+ [(part-relative-element? s) (element-width ((part-relative-element-sizer s)))]
[else 1]))
(define (paragraph-width s)
diff --git a/collects/scribble/xref.ss b/collects/scribble/xref.ss
@@ -4,6 +4,7 @@
scribble/manual-struct
scribble/decode-struct
scribble/base-render
+ scribble/search
(prefix-in html: scribble/html-render)
scheme/class
mzlib/serialize
@@ -74,46 +75,50 @@
(void))))
;; Returns (values <tag-or-#f> <form?>)
-(define (xref-binding-tag xrefs src id)
- (let ([search
- (lambda (src)
- (let ([base (format ":~a:~a"
- (if (path? src)
- (path->main-collects-relative src)
- src)
- id)]
- [ht (collect-info-ext-ht (resolve-info-ci (xrefs-ri xrefs)))])
- (let ([form-tag `(form ,base)]
- [val-tag `(def ,base)])
- (if (hash-table-get ht form-tag #f)
- (values form-tag #t)
- (if (hash-table-get ht val-tag #f)
- (values val-tag #f)
- (values #f #f))))))])
- (let loop ([src src])
+(define xref-binding-tag
+ (case-lambda
+ [(xrefs id/binding mode)
+ (let ([search
+ (lambda (id/binding)
+ (let ([tag (find-scheme-tag #f (xrefs-ri xrefs) id/binding mode)])
+ (if tag
+ (values tag (eq? (car tag) 'form))
+ (values #f #f))))])
(cond
- [(path? src)
- (if (complete-path? src)
- (search src)
- (loop (path->complete-path src)))]
- [(path-string? src)
- (loop (path->complete-path src))]
- [(resolved-module-path? src)
- (let ([n (resolved-module-path-name src)])
- (if (pair? n)
- (loop n)
- (search n)))]
- [(module-path-index? src)
- (loop (module-path-index-resolve src))]
- [(module-path? src)
- (loop (module-path-index-join src #f))]
- [else
- (raise-type-error 'xref-binding-definition->tag
- "module path, resolved module path, module path index, path, or string"
- src)]))))
-
-(define (xref-binding->definition-tag xrefs src id)
- (let-values ([(tag form?) (xref-binding-tag xrefs src id)])
+ [(identifier? id/binding)
+ (search id/binding)]
+ [(and (list? id/binding)
+ (= 6 (length id/binding)))
+ (search id/binding)]
+ [(and (list? id/binding)
+ (= 2 (length id/binding)))
+ (let loop ([src (car id/binding)])
+ (cond
+ [(path? src)
+ (if (complete-path? src)
+ (search (list src (cadr id/binding)))
+ (loop (path->complete-path src)))]
+ [(path-string? src)
+ (loop (path->complete-path src))]
+ [(resolved-module-path? src)
+ (let ([n (resolved-module-path-name src)])
+ (if (pair? n)
+ (loop n)
+ (search n)))]
+ [(module-path-index? src)
+ (loop (module-path-index-resolve src))]
+ [(module-path? src)
+ (loop (module-path-index-join src #f))]
+ [else
+ (raise-type-error 'xref-binding-definition->tag
+ "list starting with module path, resolved module path, module path index, path, or string"
+ src)]))]
+ [else (raise-type-error 'xref-binding-definition->tag
+ "identifier, 2-element list, or 6-element list"
+ id/binding)]))]))
+
+(define (xref-binding->definition-tag xrefs id/binding mode)
+ (let-values ([(tag form?) (xref-binding-tag xrefs id/binding mode)])
tag))
(define (xref-tag->path+anchor xrefs tag #:render% [render% (html:render-mixin render%)])
diff --git a/collects/scribblings/scribble/bnf.scrbl b/collects/scribblings/scribble/bnf.scrbl
@@ -3,7 +3,7 @@
"utils.ss"
(for-label scribble/bnf))
-@title[#:tag "bnf"]{Typesetting Grammars}
+@title[#:tag "bnf"]{BNF Grammars}
@defmodule[scribble/bnf]{The @scheme[scribble/bnf] library
provides utilities for typesetting grammars.}
diff --git a/collects/scribblings/scribble/decode.scrbl b/collects/scribblings/scribble/decode.scrbl
@@ -2,7 +2,7 @@
@require[scribble/manual]
@require["utils.ss"]
-@title[#:tag "decode"]{Text Decoder}
+@title[#:tag "decode"]{Decoding Text}
@defmodule[scribble/decode]{The @schememodname[scribble/decode]
library helps you write document content in a natural way---more like
diff --git a/collects/scribblings/scribble/doclang.scrbl b/collects/scribblings/scribble/doclang.scrbl
@@ -2,9 +2,9 @@
@require[scribble/manual]
@require["utils.ss"]
-@title[#:tag "doclang"]{Document Module Language}
+@title[#:tag "doclang"]{Document Language}
-@defmodule[scribble/doclang]{The @schememodname[scribble/doclang]
+@defmodulelang[scribble/doclang]{The @schememodname[scribble/doclang]
language provides everything from @scheme[scheme/base], except that it
replaces the @scheme[#%module-begin] form.}
diff --git a/collects/scribblings/scribble/docreader.scrbl b/collects/scribblings/scribble/docreader.scrbl
@@ -5,7 +5,7 @@
@title[#:tag "docreader"]{Document Reader}
-@defmodule[scribble/doc]{The @schememodname[scribble/doc] language is
+@defmodulelang[scribble/doc]{The @schememodname[scribble/doc] language is
the same as @schememodname[scribble/doclang], except that
@scheme[read-inside-syntax] is used to read the body of the module. In
other words, the module body starts in Scribble ``text'' mode instead
diff --git a/collects/scribblings/scribble/how-to.scrbl b/collects/scribblings/scribble/how-to.scrbl
@@ -292,7 +292,9 @@ hyperlinks.
To document a @scheme[my-helper] procedure that is exported by
@filepath{helper.ss} in the collection that contains
@filepath{manual.scrbl}, first use @scheme[(require (for-label ....))]
-to import the binding information of @filepath{helper.ss}. Then use
+to import the binding information of @filepath{helper.ss}. Then add a
+@scheme[defmodule] declaration, which connects the @scheme[for-label]
+binding with the module path as seen by a reader. Finally, use
@scheme[defproc] to document the procedure:
@verbatim[#<<EOS
@@ -303,6 +305,8 @@ to import the binding information of @filepath{helper.ss}. Then use
@title{My Library}
+ @defmodule[my-lib/helper]
+
@defproc[(my-helper [lst list?])
(listof
(not/c (one-of/c 'cow)))]{
@@ -320,30 +324,6 @@ of the result must be given; in this case, @scheme[my-helper]
guarantees a result that is a list where none of the elements are
@scheme['cow].
-Finally, the documentation should declare the module that is being
-defined. Use @scheme[defmodule] to declare the module name before any
-other definitions.
-
-@verbatim[#<<EOS
- #lang scribble/doc
- @(require scribble/manual
- (for-label scheme
- "helper.ss"))
-
- @title{My Library}
-
- @defmodule[my-lib/helper]{The @schememodname[my-lib/helper]
- module---now with extra cows!}
-
- @defproc[(my-helper [lst list?])
- (listof
- (not/c (one-of/c 'cow)))]{
-
- Replaces each @scheme['cow] in @scheme[lst] with
- @scheme['aardvark].}
-EOS
-]
-
Some things to notice in this example and the documentation that it
generates:
diff --git a/collects/scribblings/scribble/manual.scrbl b/collects/scribblings/scribble/manual.scrbl
@@ -4,7 +4,7 @@
(for-syntax scheme/base)
(for-label scribble/manual-struct))
-@title[#:tag "manual"]{PLT Manual Forms}
+@title[#:tag "manual"]{Manual Forms}
@defmodule[scribble/manual]{The @schememodname[scribble/manual]
library provides all of @schememodname[scribble/basic], plus
@@ -39,9 +39,9 @@ because that's the way it is idented the use of @scheme[schemeblock].
Furthermore, @scheme[define] is typeset as a keyword (bold and black)
and as a hyperlink to @scheme[define]'s definition in the reference
manual, because this document was built using a for-label binding of
-@scheme[define] (in the source) that matches the for-label binding of
-the definition in the reference manual. Similarly, @scheme[not] is a
-hyperlink to the its definition in the reference manual.
+@scheme[define] (in the source) that matches a definition in the
+reference manual. Similarly, @scheme[not] is a hyperlink to the its
+definition in the reference manual.
Use @scheme[unsyntax] to escape back to an expression that produces an
@scheme[element]. For example,
@@ -252,10 +252,14 @@ Produces a sequence of flow elements (encapsulated in a
@scheme[prototype]s corresponds to a curried function, as in
@scheme[define]. The @scheme[id] is indexed, and it also registered so
that @scheme[scheme]-typeset uses of the identifier (with the same
-for-label binding) are hyperlinked to this documentation. The
-@scheme[id] should have a for-label binding (as introduced by
-@scheme[require-for-label]) that determines the module binding being
-defined.
+for-label binding) are hyperlinked to this documentation.
+
+A @scheme[defmodule] or @scheme[declare-exporting] form (or one of the
+variants) in an enclosing section determines the @scheme[id] binding
+that is being defined. The @scheme[id] should also have a for-label
+binding (as introduced by @scheme[(require (for-label ...))]) that
+matches the definition binding; otherwise, the defined @scheme[id]
+will not typeset correctly within the definition.
Each @scheme[arg-spec] must have one of the following forms:
@@ -317,10 +321,11 @@ Produces a a sequence of flow elements (encaptured in a
@scheme[splice]) to document a syntatic form named by @scheme[id]. The
@scheme[id] is indexed, and it is also registered so that
@scheme[scheme]-typeset uses of the identifier (with the same
-for-label binding) are hyperlinked to this documentation. The
-@scheme[id] should have a for-label binding (as introduced by
-@scheme[require-for-label]) that determines the module binding being
-defined.
+for-label binding) are hyperlinked to this documentation.
+
+The @scheme[defmodule] or @scheme[declare-exporting] requires, as well
+as the binding requirements for @scheme[id], are the same as for
+@scheme[defproc].
The @tech{decode}d @scheme[pre-flow] documents the procedure. In this
description, a reference to any identifier in @scheme[datum] via
@@ -504,6 +509,19 @@ Like @scheme[defclass], but for an interfaces. Naturally,
Like @scheme[definterface], but for single-page rendering as in
@scheme[defclass/title].}
+@defform[(defmixin id (domain-id ...) (range-id ...) pre-flow ...)]{
+
+Like @scheme[defclass], but for a mixin. Any number of
+@scheme[domain-id] classes and interfaces are specified for the
+mixin's input requires, and any number of result classes and (more
+likely) interfaces are specified for the @scheme[range-id]. The
+@scheme[domain-id]s supply inherited methods.}
+
+@defform[(defmixin/title id (domain-id ...) (range-id ...) pre-flow ...)]{
+
+Like @scheme[defmixin], but for single-page rendering as in
+@scheme[defclass/title].}
+
@defform/subs[(defconstructor (arg-spec ...) pre-flow ...)
([arg-spec (arg-id contract-expr-datum)
(arg-id contract-expr-datum default-expr)])]{
@@ -867,6 +885,11 @@ class via @scheme[defclass] and company.}
Indicates that the index entry corresponds to the definition of an
interface via @scheme[definterface] and company.}
+@defstruct[(mixin-index-desc exported-index-desc) ()]{
+
+Indicates that the index entry corresponds to the definition of a
+mixin via @scheme[defmixin] and company.}
+
@defstruct[(method-index-desc exported-index-desc) ([method-name symbol?]
[class-tag tag?])]{
diff --git a/collects/scribblings/scribble/reader.scrbl b/collects/scribblings/scribble/reader.scrbl
@@ -5,7 +5,7 @@
@require["utils.ss"]
@require[(for-syntax scheme/base)]
-@title[#:tag "reader"]{The Scribble Reader}
+@title[#:tag "reader"]{@"@"-Reader}
The Scribble @"@"-reader is designed to be a convenient facility for
using free-form text in Scheme code, where ``@"@"'' is chosen as one of
diff --git a/collects/scribblings/scribble/struct.scrbl b/collects/scribblings/scribble/struct.scrbl
@@ -3,7 +3,7 @@
"utils.ss"
(for-label scribble/manual-struct))
-@title[#:tag "struct"]{Document Structures And Processing}
+@title[#:tag "struct"]{Structures And Processing}
@defmodule[scribble/struct]
diff --git a/collects/scribblings/scribble/xref.scrbl b/collects/scribblings/scribble/xref.scrbl
@@ -39,17 +39,67 @@ get all cross-reference information for installed documentation.}
@defproc[(xref-binding->definition-tag [xref xref?]
- [mod (or/c module-path?
- module-path-index?
- path?
- resolved-module-path?)]
- [sym symbol?])
+ [binding (or/c identifier?
+ (list/c (or/c module-path?
+ module-path-index?
+ path?
+ resolved-module-path?)
+ symbol?)
+ (listof module-path-index?
+ symbol?
+ module-path-index?
+ symbol?
+ boolean?
+ (one-of/c #f 'for-syntax 'for-label))
+ (list/c (or/c module-path?
+ module-path-index?
+ path?
+ resolved-module-path?)
+ symbol?
+ (one-of/c #f 'for-syntax 'for-label)))]
+ [mode (one-of/c #f 'for-syntax 'for-label)])
(or/c tag? false/c)]{
-Locates a tag in @scheme[xref] that documents @scheme[sym] as defined
-by @scheme[mod]. The @scheme[sym] and @scheme[mod] combination
-correspond to the first two elements of a @scheme[identifier-binding]
-list result.
+Locates a tag in @scheme[xref] that documents a module export. The
+binding is specified in one of several ways, as described below; all
+possibilities encode an exporting module and a symbolic name. The name
+must be exported from the specified module. Documentation is found
+either for the specified module or, if the exported name is
+re-exported from other other module, for the other module
+(transitively).
+
+The @scheme[mode] argument specifies more information about the
+binding: whether it refers to a normal binding, a @scheme[for-syntax]
+binding, or a @scheme[for-label] binding.
+
+The @scheme[binding] is specified in one of four ways:
+
+@itemize{
+
+ @item{If @scheme[binding] is an identifier, then
+ @scheme[identifier-binding],
+ @scheme[identifier-transformer-binding], or
+ @scheme[identifier-label-binding] is used to determine the
+ binding, depending on the value of @scheme[mode].}
+
+ @item{If @scheme[binding] is a two-element list, then the first
+ element provides the exporting module and the second the
+ exported name. The @scheme[mode] argument is effectively
+ ignored.}
+
+ @item{If @scheme[binding] is a six-element list, then it corresponds
+ to a result from @scheme[identifier-binding],
+ @scheme[identifier-transformer-binding], or
+ @scheme[identifier-label-binding], depending on the value of
+ @scheme[mode].}
+
+ @item{If @scheme[binding] is a three-element list, then the first
+ element is as for the 2-element-list case, the second element
+ is like the fourth element of the six-element case, and the
+ third element is like the sixth element of the six-element
+ case.}
+
+}
If a documentation point exists in @scheme[xref], a tag is returned,
which might be used with @scheme[xref-tag->path+anchor] or embedded in
