diff --git a/scribble-lib/scribble/blueboxes.rkt b/scribble-lib/scribble/blueboxes.rkt index 233c9941..9db4b17e 100644 --- a/scribble-lib/scribble/blueboxes.rkt +++ b/scribble-lib/scribble/blueboxes.rkt @@ -2,16 +2,20 @@ (require setup/dirs racket/serialize racket/contract - scribble/core) + 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?)])) + [blueboxes-cache? (-> any/c boolean?)] + [fetch-blueboxes-method-tags (->* (symbol?) (#:blueboxes-cache blueboxes-cache?) + (listof method-tag?))])) -(struct blueboxes-cache (info-or-paths) #:mutable) +(struct blueboxes-cache (info-or-paths method->tags) #:mutable) (define (make-blueboxes-cache populate? #:blueboxes-dirs @@ -20,26 +24,23 @@ (directory-list d) '()))]) (build-path d c))]) - (define cache (blueboxes-cache blueboxes-dirs)) + (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 - (pair? tag) - (eq? (car tag) 'def)) + [(and plain-strs (definition-tag? tag)) (define constructor-strs - (fetch-strs-for-single-tag (cons 'constructor (cdr tag)) cache)) - (if constructor-strs - (append plain-strs - '("") - ;; cdr drops the "white label" line (constructor, presumably) - (cdr constructor-strs)) - plain-strs)] - [else - plain-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) @@ -47,25 +48,46 @@ (define offset+lens (hash-ref (list-ref ent 2) tag #f)) (cond [offset+lens - (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))))))] + (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)))) + (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))) -;; build-blueboxes-cache : (listof (list file-path int hash[tag -o> (cons int int)])) +(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 @@ -83,8 +105,23 @@ x (exn-message x)) #f)]) - (deserialize (read port)))) + (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))