aca15dcc85
The current expader's `namespace-require` has a bug that prevents it from reporting a conclict when `(for-label <lib>)` creates a conflict due to different provided bindings of the same name at different phases from <lib>. Avoid depending on that bug.
274 lines
11 KiB
Racket
274 lines
11 KiB
Racket
#lang scheme/base
|
|
(require racket/string
|
|
racket/format
|
|
"../struct.rkt"
|
|
"../scheme.rkt"
|
|
"../search.rkt"
|
|
"../basic.rkt"
|
|
"../manual-struct.rkt"
|
|
(only-in "../core.rkt" make-style)
|
|
"../html-properties.rkt"
|
|
"manual-ex.rkt"
|
|
racket/contract/base
|
|
(for-syntax scheme/base)
|
|
(for-label scheme/base
|
|
scheme/class))
|
|
|
|
(provide definition-site
|
|
libs->taglet
|
|
annote-exporting-library
|
|
with-exporting-libraries
|
|
id-to-target-maker
|
|
id-to-form-target-maker
|
|
*sig-elem
|
|
(struct-out sig)
|
|
;; public:
|
|
; XXX unknown contract
|
|
make-binding-redirect-elements
|
|
sigelem)
|
|
(provide/contract
|
|
; XXX What is return type?
|
|
[defidentifier ((identifier?) (#:form? boolean? #:index? boolean? #:show-libs? boolean?) . ->* . any/c)])
|
|
|
|
(define (gen-absolute-tag)
|
|
`(abs ,(make-generated-tag)))
|
|
|
|
(define-struct sig (id))
|
|
|
|
(define-syntax-rule (sigelem sig elem)
|
|
(*sig-elem (quote-syntax sig) 'elem))
|
|
|
|
(define (*sig-elem sig elem #:defn? [defn? #f])
|
|
(let ([s (to-element/no-color elem)])
|
|
(make-delayed-element
|
|
(lambda (renderer sec ri)
|
|
(let* ([tag (find-scheme-tag sec ri sig #f)]
|
|
[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))])
|
|
(make-element
|
|
symbol-color
|
|
(list
|
|
(cond [sd (make-link-element (if defn? syntax-def-color syntax-link-color) (list s) stag)]
|
|
[vtag (make-link-element (if defn? value-def-color value-link-color) (list s) vtag)]
|
|
[else s])))))
|
|
(lambda () s)
|
|
(lambda () s))))
|
|
|
|
(define hovers (make-weak-hasheq))
|
|
(define (intern-hover-style text)
|
|
(let ([text (datum-intern-literal text)])
|
|
(or (hash-ref hovers text #f)
|
|
(let ([s (make-style #f (list (make-hover-property text)))])
|
|
(hash-set! hovers text s)
|
|
s))))
|
|
|
|
(define (annote-exporting-library e)
|
|
(make-delayed-element
|
|
(lambda (render p ri)
|
|
(let ([from (resolve-get/tentative p ri '(exporting-libraries #f))])
|
|
(if (and from (pair? from))
|
|
(make-element
|
|
(intern-hover-style
|
|
(string-append
|
|
"Provided from: "
|
|
(string-join (map ~s from) ", ")
|
|
(let ([from-pkgs (resolve-get/tentative p ri '(exporting-packages #f))])
|
|
(if (and from-pkgs (pair? from-pkgs))
|
|
(string-append
|
|
" | Package: "
|
|
(string-join (map ~a from-pkgs) ", "))
|
|
""))))
|
|
e)
|
|
e)))
|
|
(lambda () e)
|
|
(lambda () e)))
|
|
|
|
(define (get-exporting-libraries render p ri)
|
|
(resolve-get/tentative p ri '(exporting-libraries #f)))
|
|
|
|
(define (with-exporting-libraries proc)
|
|
(make-delayed-index-desc
|
|
(lambda (render part ri)
|
|
(proc (or (get-exporting-libraries render part ri) null)))))
|
|
|
|
(define (definition-site name stx-id form?)
|
|
(let ([sig (current-signature)])
|
|
(define (gen defn?)
|
|
(if sig
|
|
(*sig-elem #:defn? defn? (sig-id sig) name)
|
|
((if defn? annote-exporting-library values)
|
|
(to-element #:defn? defn? (make-just-context name stx-id)))))
|
|
(values (gen #t) (gen #f))))
|
|
|
|
(define checkers (make-hash))
|
|
|
|
(define (libs->taglet id libs source-libs)
|
|
(let ([lib
|
|
(or (ormap (lambda (lib)
|
|
(let ([checker
|
|
(hash-ref
|
|
checkers lib
|
|
(lambda ()
|
|
(let ([ns-id
|
|
(let ([ns (make-base-empty-namespace)])
|
|
(parameterize ([current-namespace ns])
|
|
;; A `(namespace-require `(for-label ,lib))` can
|
|
;; fail if `lib` provides different bindings of the
|
|
;; same name at different phases. We can require phases
|
|
;; 1 and 0 separately, in which case the phase-0
|
|
;; binding shadows the phase-1 one in that case.
|
|
;; This strategy only works for documenting bindings
|
|
;; at phases 0 and 1, though.
|
|
(namespace-require `(just-meta 1 (for-label ,lib)))
|
|
(namespace-require `(just-meta 0 (for-label ,lib)))
|
|
(namespace-syntax-introduce (datum->syntax #f 'x))))])
|
|
(let ([checker
|
|
(lambda (id)
|
|
(free-label-identifier=?
|
|
(datum->syntax ns-id (syntax-e id))
|
|
id))])
|
|
(hash-set! checkers lib checker)
|
|
checker))))])
|
|
(and (checker id) lib)))
|
|
(or source-libs null))
|
|
(and (pair? libs) (car libs)))])
|
|
(and lib (module-path-index->taglet
|
|
(module-path-index-join lib #f)))))
|
|
|
|
(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)])
|
|
(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)
|
|
(eprintf "~a\n" (exn-message exn)))])
|
|
(raise-syntax-error
|
|
'WARNING
|
|
"no declared exporting libraries for definition" id)))
|
|
(if e
|
|
(let* ([lib-taglet (libs->taglet
|
|
(if sig (sig-id sig) id)
|
|
(exporting-libraries-libs e)
|
|
(exporting-libraries-source-libs e))]
|
|
[tag (intern-taglet
|
|
(list (if sig
|
|
(case sym
|
|
[(def) 'sig-val]
|
|
[(form) 'sig-def])
|
|
sym)
|
|
`(,lib-taglet
|
|
,@(if sig (list (syntax-e (sig-id sig))) null)
|
|
,(syntax-e id))))])
|
|
(if (or sig (not dep?))
|
|
(mk tag)
|
|
(make-dep (list lib-taglet (syntax-e id))
|
|
(mk tag))))
|
|
content)))
|
|
(lambda () content)
|
|
(lambda () content)))))
|
|
|
|
(define (defidentifier id
|
|
#:form? [form? #f]
|
|
#:index? [index? #t]
|
|
#:show-libs? [show-libs? #t])
|
|
;; This function could have more optional argument to select
|
|
;; whether to index the id, include a toc link, etc.
|
|
(let ([dep? #t])
|
|
(let ([maker (if form?
|
|
(id-to-form-target-maker id dep?)
|
|
(id-to-target-maker id dep?))])
|
|
(define-values (elem elem-ref)
|
|
(if show-libs?
|
|
(definition-site (syntax-e id) id form?)
|
|
(values (to-element id #:defn? #t)
|
|
(to-element id))))
|
|
(if maker
|
|
(maker elem
|
|
(lambda (tag)
|
|
(let ([elem
|
|
(if index?
|
|
(make-index-element
|
|
#f (list elem) tag
|
|
(list (datum-intern-literal (symbol->string (syntax-e id))))
|
|
(list elem)
|
|
(and show-libs?
|
|
(with-exporting-libraries
|
|
(lambda (libs)
|
|
(make-exported-index-desc (syntax-e id)
|
|
libs)))))
|
|
elem)])
|
|
(make-target-element #f (list elem) tag))))
|
|
elem))))
|
|
|
|
(define (make-binding-redirect-elements mod-path redirects)
|
|
(let ([taglet (module-path-index->taglet
|
|
(module-path-index-join mod-path #f))])
|
|
(make-element
|
|
#f
|
|
(map
|
|
(lambda (redirect)
|
|
(let ([id (car redirect)]
|
|
[form? (cadr redirect)]
|
|
[path (caddr redirect)]
|
|
[anchor (cadddr redirect)])
|
|
(let ([make-one
|
|
(lambda (kind)
|
|
(make-redirect-target-element
|
|
#f
|
|
null
|
|
(intern-taglet (list kind (list taglet id)))
|
|
path
|
|
anchor))])
|
|
(make-element
|
|
#f
|
|
(list (make-one (if form? 'form 'def))
|
|
(make-dep (list taglet id) null)
|
|
(let ([str (datum-intern-literal (symbol->string id))])
|
|
(make-index-element #f
|
|
null
|
|
(intern-taglet
|
|
(list (if form? 'form 'def)
|
|
(list taglet id)))
|
|
(list str)
|
|
(list
|
|
(make-element
|
|
symbol-color
|
|
(list
|
|
(make-element
|
|
(if form?
|
|
syntax-link-color
|
|
value-link-color)
|
|
(list str)))))
|
|
((if form?
|
|
make-form-index-desc
|
|
make-procedure-index-desc)
|
|
id
|
|
(list mod-path)))))))))
|
|
redirects))))
|
|
|
|
|
|
(define (make-dep t content)
|
|
(make-collect-element
|
|
#f
|
|
content
|
|
(lambda (ci)
|
|
(collect-put! ci
|
|
(intern-taglet (list 'dep t))
|
|
#t))))
|