add fetch-blueboxes-method-tags and improve the sanitization of the blueboxes data

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
+    [(and plain-strs (definition-tag? tag))
-          (pair? tag)
-          (eq? (car tag) 'def))
      (define constructor-strs 
-       (fetch-strs-for-single-tag (cons 'constructor (cdr tag)) cache))
+       (fetch-strs-for-single-tag
-     (if constructor-strs
+        (class/interface-tag->constructor-tag
-         (append plain-strs 
+         (definition-tag->class/interface-tag tag))
-                 '("") 
+        cache))
-                 ;; cdr drops the "white label" line (constructor, presumably)
+     (append plain-strs
-                 (cdr constructor-strs))
+             (if constructor-strs '("") '())
-         plain-strs)]
+             (if constructor-strs (cdr constructor-strs) '()))]
-    [else
+    [else plain-strs]))
-     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
+       (define lines
-        append
+         (apply
-        (for/list ([offset+len (in-list offset+lens)])
+          append
-          (define fn (list-ref ent 0))
+          (for/list ([offset+len (in-list offset+lens)])
-          (define offset (list-ref ent 1))
+            (define fn (list-ref ent 0))
-          (call-with-input-file fn
+            (define offset (list-ref ent 1))
-            (λ (port)
+            (call-with-input-file fn
-              (port-count-lines! port)
+              (λ (port)
-              (file-position port (+ (car offset+len) offset))
+                (port-count-lines! port)
-              (for/list ([i (in-range (cdr offset+len))])
+                (file-position port (+ (car offset+len) offset))
-                (read-line port))))))]
+                (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))