suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

3.99.0.9: binding links in docs use nominal import sources

Browse Source 
svn: r8196

original commit: 7fc41024c0f09d03bed22c9e68bc2548f9222b77
This commit is contained in:
Matthew Flatt 2008-01-03 19:07:02 +00:00
parent 7de01e897e
commit aee87f3568
18 changed files with 717 additions and 368 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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

8
collects/scribble/basic.ss
View File

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

3
collects/scribble/decode.ss
View File

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

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

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

510
collects/scribble/manual.ss
View File

@ -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 (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-form-tag id)
(add-signature-tag id #t))
(define (id-to-target-maker id dep?)
(*id-to-target-maker 'def id dep?))
(define (add-signature-tag id form?)
(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)))
(**method sym id))
(define (**method sym tag)
(make-element
"schemesymbol"
(list (make-link-element
"schemevaluelink"
(list (symbol->string sym))
(method-tag tag sym)))))
(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)

77
collects/scribble/scheme.ss
View File

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

126
collects/scribble/search.ss Normal file
View File

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

66
collects/scribble/struct.ss
View File

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

81
collects/scribble/xref.ss
View File

@ -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)]))))
[(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 src id)
(let-values ([(tag form?) (xref-binding-tag xrefs src id)])
(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%)])

2
collects/scribblings/scribble/bnf.scrbl
View File

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

2
collects/scribblings/scribble/decode.scrbl
View File

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

4
collects/scribblings/scribble/doclang.scrbl
View File

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

2
collects/scribblings/scribble/docreader.scrbl
View File

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

30
collects/scribblings/scribble/how-to.scrbl
View File

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

47
collects/scribblings/scribble/manual.scrbl
View File

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

2
collects/scribblings/scribble/reader.scrbl
View File

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

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

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

68
collects/scribblings/scribble/xref.scrbl
View File

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