manual-bind.rkt (11098B)
1 #lang scheme/base 2 (require racket/string 3 racket/format 4 "../struct.rkt" 5 "../scheme.rkt" 6 "../search.rkt" 7 "../basic.rkt" 8 "../manual-struct.rkt" 9 (only-in "../core.rkt" make-style) 10 "../html-properties.rkt" 11 "manual-ex.rkt" 12 racket/contract/base 13 (for-syntax scheme/base) 14 (for-label scheme/base 15 scheme/class)) 16 17 (provide definition-site 18 libs->taglet 19 annote-exporting-library 20 with-exporting-libraries 21 id-to-target-maker 22 id-to-form-target-maker 23 *sig-elem 24 (struct-out sig) 25 ;; public: 26 ; XXX unknown contract 27 make-binding-redirect-elements 28 sigelem) 29 (provide/contract 30 ; XXX What is return type? 31 [defidentifier ((identifier?) (#:form? boolean? #:index? boolean? #:show-libs? boolean?) . ->* . any/c)]) 32 33 (define (gen-absolute-tag) 34 `(abs ,(make-generated-tag))) 35 36 (define-struct sig (id)) 37 38 (define-syntax-rule (sigelem sig elem) 39 (*sig-elem (quote-syntax sig) 'elem)) 40 41 (define (*sig-elem sig elem #:defn? [defn? #f]) 42 (let ([s (to-element/no-color elem)]) 43 (make-delayed-element 44 (lambda (renderer sec ri) 45 (let* ([tag (find-scheme-tag sec ri sig #f)] 46 [taglet (and tag (append (cadr tag) (list elem)))] 47 [vtag (and tag `(sig-val ,taglet))] 48 [stag (and tag `(sig-form ,taglet))] 49 [sd (and stag (resolve-get/tentative sec ri stag))]) 50 (make-element 51 symbol-color 52 (list 53 (cond [sd (make-link-element (if defn? syntax-def-color syntax-link-color) (list s) stag)] 54 [vtag (make-link-element (if defn? value-def-color value-link-color) (list s) vtag)] 55 [else s]))))) 56 (lambda () s) 57 (lambda () s)))) 58 59 (define hovers (make-weak-hasheq)) 60 (define (intern-hover-style text) 61 (let ([text (datum-intern-literal text)]) 62 (or (hash-ref hovers text #f) 63 (let ([s (make-style #f (list (make-hover-property text)))]) 64 (hash-set! hovers text s) 65 s)))) 66 67 (define (annote-exporting-library e) 68 (make-delayed-element 69 (lambda (render p ri) 70 (let ([from (resolve-get/tentative p ri '(exporting-libraries #f))]) 71 (if (and from (pair? from)) 72 (make-element 73 (intern-hover-style 74 (string-append 75 "Provided from: " 76 (string-join (map ~s from) ", ") 77 (let ([from-pkgs (resolve-get/tentative p ri '(exporting-packages #f))]) 78 (if (and from-pkgs (pair? from-pkgs)) 79 (string-append 80 " | Package: " 81 (string-join (map ~a from-pkgs) ", ")) 82 "")))) 83 e) 84 e))) 85 (lambda () e) 86 (lambda () e))) 87 88 (define (get-exporting-libraries render p ri) 89 (resolve-get/tentative p ri '(exporting-libraries #f))) 90 91 (define (with-exporting-libraries proc) 92 (make-delayed-index-desc 93 (lambda (render part ri) 94 (proc (or (get-exporting-libraries render part ri) null))))) 95 96 (define (definition-site name stx-id form?) 97 (let ([sig (current-signature)]) 98 (define (gen defn?) 99 (if sig 100 (*sig-elem #:defn? defn? (sig-id sig) name) 101 ((if defn? annote-exporting-library values) 102 (to-element #:defn? defn? (make-just-context name stx-id))))) 103 (values (gen #t) (gen #f)))) 104 105 (define checkers (make-hash)) 106 107 (define (libs->taglet id libs source-libs) 108 (let ([lib 109 (or (ormap (lambda (lib) 110 (let ([checker 111 (hash-ref 112 checkers lib 113 (lambda () 114 (let ([ns-id 115 (let ([ns (make-base-empty-namespace)]) 116 (parameterize ([current-namespace ns]) 117 ;; A `(namespace-require `(for-label ,lib))` can 118 ;; fail if `lib` provides different bindings of the 119 ;; same name at different phases. We can require phases 120 ;; 1 and 0 separately, in which case the phase-0 121 ;; binding shadows the phase-1 one in that case. 122 ;; This strategy only works for documenting bindings 123 ;; at phases 0 and 1, though. 124 (namespace-require `(just-meta 1 (for-label ,lib))) 125 (namespace-require `(just-meta 0 (for-label ,lib))) 126 (namespace-syntax-introduce (datum->syntax #f 'x))))]) 127 (let ([checker 128 (lambda (id) 129 (free-label-identifier=? 130 (datum->syntax ns-id (syntax-e id)) 131 id))]) 132 (hash-set! checkers lib checker) 133 checker))))]) 134 (and (checker id) lib))) 135 (or source-libs null)) 136 (and (pair? libs) (car libs)))]) 137 (and lib (module-path-index->taglet 138 (module-path-index-join lib #f))))) 139 140 (define (id-to-target-maker id dep?) 141 (*id-to-target-maker 'def id dep?)) 142 143 (define (id-to-form-target-maker id dep?) 144 (*id-to-target-maker 'form id dep?)) 145 146 (define (*id-to-target-maker sym id dep?) 147 (let ([sig (current-signature)]) 148 (lambda (content mk) 149 (make-part-relative-element 150 (lambda (ci) 151 (let ([e (ormap (lambda (p) 152 (ormap (lambda (e) 153 (and (exporting-libraries? e) e)) 154 (part-to-collect p))) 155 (collect-info-parents ci))]) 156 (unless e 157 ;; Call raise-syntax-error to capture error message: 158 (with-handlers ([exn:fail:syntax? 159 (lambda (exn) 160 (eprintf "~a\n" (exn-message exn)))]) 161 (raise-syntax-error 162 'WARNING 163 "no declared exporting libraries for definition" id))) 164 (if e 165 (let* ([lib-taglet (libs->taglet 166 (if sig (sig-id sig) id) 167 (exporting-libraries-libs e) 168 (exporting-libraries-source-libs e))] 169 [tag (intern-taglet 170 (list (if sig 171 (case sym 172 [(def) 'sig-val] 173 [(form) 'sig-def]) 174 sym) 175 `(,lib-taglet 176 ,@(if sig (list (syntax-e (sig-id sig))) null) 177 ,(syntax-e id))))]) 178 (if (or sig (not dep?)) 179 (mk tag) 180 (make-dep (list lib-taglet (syntax-e id)) 181 (mk tag)))) 182 content))) 183 (lambda () content) 184 (lambda () content))))) 185 186 (define (defidentifier id 187 #:form? [form? #f] 188 #:index? [index? #t] 189 #:show-libs? [show-libs? #t]) 190 ;; This function could have more optional argument to select 191 ;; whether to index the id, include a toc link, etc. 192 (let ([dep? #t]) 193 (let ([maker (if form? 194 (id-to-form-target-maker id dep?) 195 (id-to-target-maker id dep?))]) 196 (define-values (elem elem-ref) 197 (if show-libs? 198 (definition-site (syntax-e id) id form?) 199 (values (to-element id #:defn? #t) 200 (to-element id)))) 201 (if maker 202 (maker elem 203 (lambda (tag) 204 (let ([elem 205 (if index? 206 (make-index-element 207 #f (list elem) tag 208 (list (datum-intern-literal (symbol->string (syntax-e id)))) 209 (list elem) 210 (and show-libs? 211 (with-exporting-libraries 212 (lambda (libs) 213 (make-exported-index-desc (syntax-e id) 214 libs))))) 215 elem)]) 216 (make-target-element #f (list elem) tag)))) 217 elem)))) 218 219 (define (make-binding-redirect-elements mod-path redirects) 220 (let ([taglet (module-path-index->taglet 221 (module-path-index-join mod-path #f))]) 222 (make-element 223 #f 224 (map 225 (lambda (redirect) 226 (let ([id (car redirect)] 227 [form? (cadr redirect)] 228 [path (caddr redirect)] 229 [anchor (cadddr redirect)]) 230 (let ([make-one 231 (lambda (kind) 232 (make-redirect-target-element 233 #f 234 null 235 (intern-taglet (list kind (list taglet id))) 236 path 237 anchor))]) 238 (make-element 239 #f 240 (list (make-one (if form? 'form 'def)) 241 (make-dep (list taglet id) null) 242 (let ([str (datum-intern-literal (symbol->string id))]) 243 (make-index-element #f 244 null 245 (intern-taglet 246 (list (if form? 'form 'def) 247 (list taglet id))) 248 (list str) 249 (list 250 (make-element 251 symbol-color 252 (list 253 (make-element 254 (if form? 255 syntax-link-color 256 value-link-color) 257 (list str))))) 258 ((if form? 259 make-form-index-desc 260 make-procedure-index-desc) 261 id 262 (list mod-path))))))))) 263 redirects)))) 264 265 266 (define (make-dep t content) 267 (make-collect-element 268 #f 269 content 270 (lambda (ci) 271 (collect-put! ci 272 (intern-taglet (list 'dep t)) 273 #t))))