xref.rkt (7466B)
1 #lang scheme/base 2 3 (require scribble/struct 4 (only-in scribble/core known-doc? known-doc-v) 5 scribble/base-render 6 scribble/search 7 (prefix-in html: scribble/html-render) 8 scheme/class 9 scheme/path) 10 11 (provide load-xref 12 xref? 13 xref-render 14 xref-index 15 xref-binding->definition-tag 16 xref-tag->path+anchor 17 xref-tag->index-entry 18 xref-transfer-info 19 (struct-out entry) 20 make-data+root 21 data+root? 22 make-data+root+doc-id 23 data+root+doc-id?) 24 25 (define-struct entry 26 (words ; list of strings: main term, sub-term, etc. 27 content ; Scribble content to the index label 28 tag ; for generating a Scribble link 29 desc)) ; further info that depends on the kind of index entry 30 31 (define-struct data+root (data root)) 32 (define-struct (data+root+doc-id data+root) (doc-id)) 33 34 ;; Private: 35 (define-struct xrefs (renderer ri)) 36 37 (define (xref? x) (xrefs? x)) 38 39 ;; ---------------------------------------- 40 ;; Xref loading 41 42 (define-namespace-anchor here) 43 44 (define (load-xref sources 45 #:demand-source [demand-source (lambda (key) #f)] 46 #:demand-source-for-use [demand-source-for-use 47 (lambda (key use-id) (demand-source key))] 48 #:render% [render% (html:render-mixin render%)] 49 #:root [root-path #f] 50 #:doc-id [doc-id-str #f]) 51 (let* ([renderer (new render% [dest-dir (find-system-path 'temp-dir)])] 52 [fp (send renderer traverse null null)] 53 [load-source (lambda (src ci) 54 (parameterize ([current-namespace 55 (namespace-anchor->empty-namespace here)]) 56 (let ([vs (src)]) 57 (for ([v (in-list (if (procedure? vs) (vs) (list vs)))]) 58 (when v 59 (define data (if (data+root? v) (data+root-data v) v)) 60 (define root (if (data+root? v) (data+root-root v) root-path)) 61 (define doc-id (or (and (data+root+doc-id? v) (data+root+doc-id-doc-id v)) 62 doc-id-str)) 63 (send renderer deserialize-info data ci 64 #:root root 65 #:doc-id doc-id))))))] 66 [use-ids (make-weak-hasheq)] 67 [ci (send renderer collect null null fp 68 (lambda (key ci) 69 (define use-obj (collect-info-ext-ht ci)) 70 (define use-id (or (hash-ref use-ids use-obj #f) 71 (let ([s (gensym 'render)]) 72 (hash-set! use-ids use-obj s) 73 s))) 74 (define src (demand-source-for-use key use-id)) 75 (and src 76 (load-source src ci))))]) 77 (for ([src sources]) 78 (load-source src ci)) 79 (make-xrefs renderer (send renderer resolve null null ci)))) 80 81 ;; ---------------------------------------- 82 ;; Xref reading 83 84 (define (xref-index xrefs) 85 (define ci (resolve-info-ci (xrefs-ri xrefs))) 86 ;; Force all xref info: 87 ((collect-info-ext-demand ci) #f ci) 88 ;; look for `index-entry' keys: 89 (for/list ([(k v) (in-hash (collect-info-ext-ht ci))] 90 #:when 91 (and (pair? k) 92 (eq? (car k) 'index-entry))) 93 (let ([v (if (known-doc? v) 94 (known-doc-v v) 95 v)]) 96 (make-entry (car v) (cadr v) (cadr k) (caddr v))))) 97 98 ;; dest-file can be #f, which will make it return a string holding the 99 ;; resulting html 100 (define (xref-render xrefs doc dest-file 101 #:render% [render% (html:render-mixin render%)] 102 #:refer-to-existing-files? [use-existing? (not dest-file)]) 103 (let* ([dest-file (if (string? dest-file) (string->path dest-file) dest-file)] 104 [renderer (new render% 105 [dest-dir (and dest-file (path-only dest-file))] 106 [refer-to-existing-files use-existing?] 107 [css-path 'inline] 108 [script-path 'inline])] 109 [ci (send renderer collect (list doc) (list dest-file))] 110 [_ (send renderer transfer-info ci (resolve-info-ci (xrefs-ri xrefs)))] 111 [ri (send renderer resolve (list doc) (list dest-file) ci)] 112 [xs (send renderer render (list doc) (list dest-file) ri)]) 113 (if dest-file 114 (void) 115 (car xs)))) 116 117 (define (xref-transfer-info renderer ci xrefs) 118 (send renderer transfer-info ci (resolve-info-ci (xrefs-ri xrefs)))) 119 120 ;; Returns (values <tag-or-#f> <form?>) 121 (define xref-binding-tag 122 (case-lambda 123 [(xrefs id/binding mode) 124 (let ([search 125 (lambda (id/binding) 126 (let ([tag (find-scheme-tag #f (xrefs-ri xrefs) id/binding mode)]) 127 (if tag 128 (values tag (eq? (car tag) 'form)) 129 (values #f #f))))]) 130 (cond 131 [(identifier? id/binding) 132 (search id/binding)] 133 [(and (list? id/binding) 134 (= 7 (length id/binding))) 135 (search id/binding)] 136 [(and (list? id/binding) 137 (= 2 (length id/binding))) 138 (let loop ([src (car id/binding)]) 139 (cond 140 [(module-path-index? src) 141 (search (list src (cadr id/binding)))] 142 [(module-path? src) 143 (loop (module-path-index-join src #f))] 144 [else 145 (raise-argument-error 'xref-binding-definition->tag 146 "(list/c (or/c module-path? module-path-index?) any/c)" 147 id/binding)]))] 148 [else (raise-argument-error 'xref-binding-definition->tag 149 (string-append 150 "(or/c identifier? (lambda (l)\n" 151 " (and (list? l)\n" 152 " (or (= (length l) 2)\n" 153 " (= (length l) 7)))))") 154 id/binding)]))])) 155 156 (define (xref-binding->definition-tag xrefs id/binding mode) 157 (let-values ([(tag form?) (xref-binding-tag xrefs id/binding mode)]) 158 tag)) 159 160 (define (xref-tag->path+anchor xrefs tag 161 #:render% [render% (html:render-mixin render%)] 162 #:external-root-url [redirect-main #f]) 163 (send (let ([r (new render% [dest-dir (find-system-path 'temp-dir)])]) 164 (when redirect-main 165 (send r set-external-root-url redirect-main)) 166 r) 167 tag->path+anchor (xrefs-ri xrefs) tag)) 168 169 (define (xref-tag->index-entry xrefs tag) 170 (let ([v (hash-ref 171 (collect-info-ext-ht (resolve-info-ci (xrefs-ri xrefs))) 172 `(index-entry ,tag) 173 #f)]) 174 (let ([v (if (known-doc? v) 175 (known-doc-v v) 176 v)]) 177 (cond [v (make-entry (car v) (cadr v) (cadr tag) (caddr v))] 178 [(and (pair? tag) (eq? 'form (car tag))) 179 ;; Try again with 'def: 180 (xref-tag->index-entry xrefs (cons 'def (cdr tag)))] 181 [else #f]))))