blueboxes.rkt (8157B)
1 #lang typed/racket/base 2 (require racket/match) 3 (require/typed setup/dirs [get-doc-search-dirs (-> (Listof Path))]) 4 (require/typed racket/serialize [deserialize (Any -> Any)]) 5 (require/typed scribble/core [#:opaque Tag tag?]) 6 (require/typed scribble/tag 7 [#:opaque Method-Tag method-tag?] 8 [#:opaque Definition-Tag definition-tag?] 9 [#:opaque Class/Interface-Tag class/interface-tag?] 10 [class/interface-tag->constructor-tag (Class/Interface-Tag -> Tag)] 11 [definition-tag->class/interface-tag (Definition-Tag -> Class/Interface-Tag)] 12 [get-class/interface-and-method (Method-Tag -> (values Symbol Symbol))] 13 ) 14 (require/typed "valid-blueboxes-info.rkt" [valid-blueboxes-info? (Any -> Boolean)]) 15 16 (provide fetch-blueboxes-strs 17 make-blueboxes-cache 18 blueboxes-cache? 19 fetch-blueboxes-method-tags 20 ) 21 22 (define-type Bluebox-Info bluebox-info) 23 (struct bluebox-info 24 ([blueboxes.rktd : Path-String] 25 [offset : (U Natural #f)] 26 [tag-ht : (U Blueboxes-Info-Hash #f)] ; (or/c valid-blueboxes-info? #f) 27 [mod-time : (U Natural #f)]) 28 #:mutable) 29 30 (define-type Blueboxes-Cache blueboxes-cache) 31 (struct blueboxes-cache 32 ([info-or-paths : (U (Listof Path) (Listof Bluebox-Info))] 33 [method->tags : (U (HashTable Symbol (Listof Method-Tag)) #f)]) 34 #:mutable) 35 36 (: make-blueboxes-cache : 37 Boolean 38 [#:blueboxes-dirs (Listof Path)] 39 -> 40 Blueboxes-Cache) 41 (define (make-blueboxes-cache 42 populate? 43 #:blueboxes-dirs 44 [blueboxes-dirs (for*/list ([d (in-list (get-doc-search-dirs))] 45 [c (in-list (if (directory-exists? d) 46 (directory-list d) 47 '()))]) 48 : (Listof Path) 49 (build-path d c))]) 50 (define cache (blueboxes-cache blueboxes-dirs #f)) 51 (when populate? (populate-cache! cache)) 52 cache) 53 54 (: fetch-blueboxes-strs : 55 Tag 56 [#:blueboxes-cache Blueboxes-Cache] 57 -> 58 (U #f (List* String (Listof String)))) 59 (define (fetch-blueboxes-strs tag #:blueboxes-cache [cache (make-blueboxes-cache #f)]) 60 (define plain-strs (fetch-strs-for-single-tag tag cache)) 61 (cond 62 [(and plain-strs (definition-tag? tag)) 63 (define constructor-strs 64 (fetch-strs-for-single-tag 65 (class/interface-tag->constructor-tag 66 (definition-tag->class/interface-tag tag)) 67 cache)) 68 (append plain-strs 69 (if constructor-strs '("") '()) 70 (if constructor-strs (cdr constructor-strs) '()))] 71 [else plain-strs])) 72 73 (: fetch-strs-for-single-tag : Tag Blueboxes-Cache -> (U #f (List* String (Listof String)))) 74 (define (fetch-strs-for-single-tag tag cache) 75 (populate-cache! cache) 76 (for/or ([ent (in-list (blueboxes-cache-info-or-paths cache))]) 77 : (U #f (List* String (Listof String))) 78 (when (bluebox-info? ent) 79 (check-and-update-bluebox-info! ent)) 80 (match ent 81 [(bluebox-info blueboxes.rktd offset tag-ht _) 82 (define offset+lens (and tag-ht (hash-ref tag-ht tag #f))) 83 (cond 84 [offset+lens 85 (define lines 86 (apply 87 append 88 (for/list ([offset+len (in-list offset+lens)]) 89 : (Listof (Listof (U String EOF))) 90 (call-with-input-file blueboxes.rktd 91 (λ ([port : Input-Port]) 92 (port-count-lines! port) 93 (file-position port (+ (car offset+len) (or offset 0))) 94 (for/list ([i (in-range (cdr offset+len))]) 95 : (Listof (U String EOF)) 96 (read-line port))))))) 97 (cond 98 [(not (andmap string? lines)) #f] 99 [(null? lines) #f] 100 [else lines])] 101 [else #f])] 102 [_ (log-warning "expected bluebox-info?, given: ~v" ent) 103 #f]))) 104 105 (: fetch-blueboxes-method-tags : Symbol [#:blueboxes-cache Blueboxes-Cache] -> (Listof Method-Tag)) 106 (define (fetch-blueboxes-method-tags sym #:blueboxes-cache [cache (make-blueboxes-cache #f)]) 107 (populate-cache! cache) 108 (define ht (blueboxes-cache-method->tags cache)) 109 (or (and ht (hash-ref ht sym (λ () '()))) '())) 110 111 (define listof-path? (make-predicate (Listof Path))) 112 113 (: populate-cache! : Blueboxes-Cache -> Void) 114 (define (populate-cache! cache) 115 (define cache-content (blueboxes-cache-info-or-paths cache)) 116 (when (listof-path? cache-content) 117 (define the-cache (build-blueboxes-cache cache-content)) 118 (define mtd-table (compute-methods-table the-cache)) 119 (set-blueboxes-cache-method->tags! cache mtd-table) 120 (set-blueboxes-cache-info-or-paths! cache the-cache))) 121 122 (: compute-methods-table : (Listof Bluebox-Info) -> (HashTable Symbol (Listof Method-Tag))) 123 (define (compute-methods-table lst) 124 (: meth-ht : (HashTable Symbol (Listof Method-Tag))) 125 (define meth-ht (make-hash)) 126 (for ([a-bluebox-info (in-list lst)]) 127 (match a-bluebox-info 128 [(bluebox-info blueboxes.rktd offset tag-ht mod-time) 129 (when tag-ht 130 (for ([(tag val) (in-hash tag-ht)]) 131 (when (method-tag? tag) 132 (define-values (class/intf meth) (get-class/interface-and-method tag)) 133 (hash-set! meth-ht meth (cons tag (hash-ref meth-ht meth (λ () '())))))))])) 134 meth-ht) 135 136 (: build-blueboxes-cache : (Listof Path) -> (Listof Bluebox-Info)) 137 (define (build-blueboxes-cache blueboxes-dirs) 138 (filter 139 values 140 (for*/list ([doc-dir-name (in-list blueboxes-dirs)]) 141 : (Listof Bluebox-Info) 142 (define blueboxes.rktd (build-path doc-dir-name "blueboxes.rktd")) 143 (define a-bluebox-info (bluebox-info blueboxes.rktd #f #f #f)) 144 (populate-bluebox-info! a-bluebox-info) 145 a-bluebox-info))) 146 147 (: check-and-update-bluebox-info! : bluebox-info -> Void) 148 (define (check-and-update-bluebox-info! a-bluebox-info) 149 (match a-bluebox-info 150 [(bluebox-info blueboxes.rktd offset tag-ht mod-time) 151 (when (or (not mod-time) 152 (and (file-exists? blueboxes.rktd) 153 (not (mod-time . = . (file-or-directory-modify-seconds blueboxes.rktd))))) 154 (populate-bluebox-info! a-bluebox-info))])) 155 156 (: populate-bluebox-info! : Bluebox-Info -> Void) 157 (define (populate-bluebox-info! a-bluebox-info) 158 (define blueboxes.rktd (bluebox-info-blueboxes.rktd a-bluebox-info)) 159 (cond 160 [(file-exists? blueboxes.rktd) 161 (call-with-input-file blueboxes.rktd 162 (λ ([port : Input-Port]) 163 (port-count-lines! port) 164 (define first-line (read-line port)) 165 (define pos (file-position port)) 166 (define desed 167 (with-handlers ([exn:fail? (λ ([x : exn:fail]) 168 (log-warning "Failed to deserialize ~a: ~a" 169 x 170 (exn-message x)) 171 #f)]) 172 (define candidate (deserialize (read port))) 173 (unless (valid-blueboxes-info? candidate) 174 (error 'build-blueboxes-cache 175 "blueboxes info didn't have the right shape: ~s" 176 candidate)) 177 (cast candidate Blueboxes-Info-Hash))) 178 (define first-line-num (and (string? first-line) (string->number first-line))) 179 (cond 180 [(exact-nonnegative-integer? first-line-num) 181 (set-bluebox-info-offset! a-bluebox-info (+ first-line-num pos))] 182 [else 183 (log-warning "expected a string representing a Natuaral\n given: ~v" 184 first-line-num)]) 185 (set-bluebox-info-tag-ht! a-bluebox-info desed) 186 (set-bluebox-info-mod-time! a-bluebox-info 187 (file-or-directory-modify-seconds blueboxes.rktd))))] 188 [else 189 (set-bluebox-info-offset! a-bluebox-info #f) 190 (set-bluebox-info-tag-ht! a-bluebox-info #f) 191 (set-bluebox-info-mod-time! a-bluebox-info #f)])) 192 193 (define-type Blueboxes-Info-Hash 194 (HashTable 195 Tag 196 (Listof (Pairof Natural 197 Natural)))) 198