From e6630f0e973a9a27b01a0eee63da22187737154d Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Wed, 15 Apr 2015 03:39:48 -0500
Subject: [PATCH] add fetch-blueboxes-method-tags and improve the sanitization
of the blueboxes data
---
scribble-lib/scribble/blueboxes.rkt | 97 ++++++++++++++++++++---------
1 file changed, 67 insertions(+), 30 deletions(-)
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))