128 lines
5.0 KiB
Racket
128 lines
5.0 KiB
Racket
#lang racket/base
|
|
(require setup/dirs
|
|
racket/serialize
|
|
racket/contract
|
|
racket/match
|
|
scribble/core
|
|
scribble/tag)
|
|
|
|
(provide
|
|
(contract-out
|
|
[fetch-blueboxes-strs (->* (tag?) (#:blueboxes-cache blueboxes-cache?)
|
|
(or/c #f (non-empty-listof string?)))]
|
|
[make-blueboxes-cache (->* (boolean?) (#:blueboxes-dirs (listof path?)) blueboxes-cache?)]
|
|
[blueboxes-cache? (-> any/c boolean?)]
|
|
[fetch-blueboxes-method-tags (->* (symbol?) (#:blueboxes-cache blueboxes-cache?)
|
|
(listof method-tag?))]))
|
|
|
|
(struct blueboxes-cache (info-or-paths method->tags) #:mutable)
|
|
(define (make-blueboxes-cache
|
|
populate?
|
|
#:blueboxes-dirs
|
|
[blueboxes-dirs (for*/list ([d (in-list (get-doc-search-dirs))]
|
|
[c (in-list (if (directory-exists? d)
|
|
(directory-list d)
|
|
'()))])
|
|
(build-path d c))])
|
|
(define cache (blueboxes-cache blueboxes-dirs #f))
|
|
(when populate? (populate-cache! cache))
|
|
cache)
|
|
|
|
(define (fetch-blueboxes-strs tag #:blueboxes-cache [cache (make-blueboxes-cache #f)])
|
|
(define plain-strs (fetch-strs-for-single-tag tag cache))
|
|
(cond
|
|
[(and plain-strs (definition-tag? tag))
|
|
(define constructor-strs
|
|
(fetch-strs-for-single-tag
|
|
(class/interface-tag->constructor-tag
|
|
(definition-tag->class/interface-tag tag))
|
|
cache))
|
|
(append plain-strs
|
|
(if constructor-strs '("") '())
|
|
(if constructor-strs (cdr constructor-strs) '()))]
|
|
[else plain-strs]))
|
|
|
|
(define (fetch-strs-for-single-tag tag cache)
|
|
(populate-cache! cache)
|
|
(for/or ([ent (in-list (blueboxes-cache-info-or-paths cache))])
|
|
(define offset+lens (hash-ref (list-ref ent 2) tag #f))
|
|
(cond
|
|
[offset+lens
|
|
(define lines
|
|
(apply
|
|
append
|
|
(for/list ([offset+len (in-list offset+lens)])
|
|
(define fn (list-ref ent 0))
|
|
(define offset (list-ref ent 1))
|
|
(call-with-input-file fn
|
|
(λ (port)
|
|
(port-count-lines! port)
|
|
(file-position port (+ (car offset+len) offset))
|
|
(for/list ([i (in-range (cdr offset+len))])
|
|
(read-line port)))))))
|
|
(cond
|
|
[(ormap eof-object? lines) #f]
|
|
[else lines])]
|
|
[else #f])))
|
|
|
|
(define (fetch-blueboxes-method-tags sym #:blueboxes-cache [cache (make-blueboxes-cache #f)])
|
|
(populate-cache! cache)
|
|
(hash-ref (blueboxes-cache-method->tags cache) sym '()))
|
|
|
|
(define (populate-cache! cache)
|
|
(define cache-content (blueboxes-cache-info-or-paths cache))
|
|
(when ((listof path?) cache-content)
|
|
(set-blueboxes-cache-info-or-paths! cache (build-blueboxes-cache cache-content))
|
|
(define mtd-table (compute-methods-table (blueboxes-cache-info-or-paths cache)))
|
|
(set-blueboxes-cache-method->tags! cache mtd-table)))
|
|
|
|
(define (compute-methods-table lst)
|
|
(define meth-ht (make-hash))
|
|
(for ([three-tuple (in-list lst)])
|
|
(match three-tuple
|
|
[`(,file-path ,i ,tag-ht)
|
|
(for ([(tag val) (in-hash tag-ht)])
|
|
(when (method-tag? tag)
|
|
(define-values (class/intf meth) (get-class/interface-and-method tag))
|
|
(hash-set! meth-ht meth (cons tag (hash-ref meth-ht meth '())))))]))
|
|
meth-ht)
|
|
|
|
;; build-blueboxes-cache : ... -> (listof (list file-path int valid-blueboxes-info?))
|
|
(define (build-blueboxes-cache blueboxes-dirs)
|
|
(filter
|
|
values
|
|
(for*/list ([doc-dir-name (in-list blueboxes-dirs)])
|
|
(define blueboxes.rktd (build-path doc-dir-name "blueboxes.rktd"))
|
|
(and (file-exists? blueboxes.rktd)
|
|
(call-with-input-file blueboxes.rktd
|
|
(λ (port)
|
|
(port-count-lines! port)
|
|
(define first-line (read-line port))
|
|
(define pos (file-position port))
|
|
(define desed
|
|
(with-handlers ([exn:fail? (λ (x)
|
|
(log-warning "Failed to deserialize ~a: ~a"
|
|
x
|
|
(exn-message x))
|
|
#f)])
|
|
(define candidate (deserialize (read port)))
|
|
(unless (valid-blueboxes-info? candidate)
|
|
(error 'build-blueboxes-cache
|
|
"blueboxes info didn't have the right shape: ~s"
|
|
candidate))
|
|
candidate))
|
|
(and desed
|
|
(list blueboxes.rktd
|
|
(+ (string->number first-line) pos)
|
|
desed))))))))
|
|
|
|
|
|
(define valid-blueboxes-info?
|
|
(hash/c
|
|
tag?
|
|
(listof (cons/dc [hd exact-nonnegative-integer?]
|
|
[tl (hd) (and/c exact-nonnegative-integer?
|
|
(>/c hd))]
|
|
#:flat))
|
|
#:flat? #t))
|