commit b1d380d4b59197b1913b1a83747b68f9f6135ec2
parent b812869d3eb9619c5a40b60a8288b91e6f91552a
Author: AlexKnauth <alexander@knauth.org>
Date: Sun, 28 Jun 2015 00:31:49 -0400
convert blueboxes.rkt to typed racket
Diffstat:
3 files changed, 103 insertions(+), 44 deletions(-)
diff --git a/scribble-lib/info.rkt b/scribble-lib/info.rkt
@@ -8,11 +8,13 @@
"scribble-text-lib"
"scribble-html-lib"
"planet-lib" ; used dynamically
- "net-lib"
+ "net-lib"
"at-exp-lib"
"draw-lib"
"syntax-color-lib"
- "sandbox-lib"))
+ "sandbox-lib"
+ "typed-racket-lib"
+ ))
(define build-deps '("rackunit-lib"
"eli-tester"))
diff --git a/scribble-lib/scribble/blueboxes.rkt b/scribble-lib/scribble/blueboxes.rkt
@@ -1,28 +1,43 @@
-#lang racket/base
-(require setup/dirs
- racket/serialize
- racket/contract
- racket/match
- scribble/core
- scribble/tag)
+#lang typed/racket/base
+(require racket/match)
+(require/typed setup/dirs [get-doc-search-dirs (-> (Listof Path))])
+(require/typed racket/serialize [deserialize (Any -> Any)])
+(require/typed scribble/core [#:opaque Tag tag?])
+(require/typed scribble/tag
+ [#:opaque Method-Tag method-tag?]
+ [#:opaque Definition-Tag definition-tag?]
+ [#:opaque Class/Interface-Tag class/interface-tag?]
+ [class/interface-tag->constructor-tag (Class/Interface-Tag -> Tag)]
+ [definition-tag->class/interface-tag (Definition-Tag -> Class/Interface-Tag)]
+ [get-class/interface-and-method (Method-Tag -> (values Symbol Symbol))]
+ )
+(require/typed "valid-blueboxes-info.rkt" [valid-blueboxes-info? (Any -> Boolean)])
-(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?))]))
+(provide fetch-blueboxes-strs
+ make-blueboxes-cache
+ blueboxes-cache?
+ fetch-blueboxes-method-tags
+ )
+(define-type Bluebox-Info bluebox-info)
+(struct bluebox-info
+ ([blueboxes.rktd : Path-String]
+ [offset : (U Natural #f)]
+ [tag-ht : (U Blueboxes-Info-Hash #f)] ; (or/c valid-blueboxes-info? #f)
+ [mod-time : (U Natural #f)])
+ #:mutable)
-;; offset : (or/c exact-nonnegative-integer? #f)
-;; tag-ht : (or/c valid-blueboxes-info? #f)
-;; mod-time : (or/c exact-nonnegative-integer? #f)
-(struct bluebox-info (blueboxes.rktd [offset #:mutable] [tag-ht #:mutable] [mod-time #:mutable]))
-
-(struct blueboxes-cache (info-or-paths method->tags) #:mutable)
+(define-type Blueboxes-Cache blueboxes-cache)
+(struct blueboxes-cache
+ ([info-or-paths : (U (Listof Path) (Listof Bluebox-Info))]
+ [method->tags : (U (HashTable Symbol (Listof Method-Tag)) #f)])
+ #:mutable)
+(: make-blueboxes-cache :
+ Boolean
+ [#:blueboxes-dirs (Listof Path)]
+ ->
+ Blueboxes-Cache)
(define (make-blueboxes-cache
populate?
#:blueboxes-dirs
@@ -30,11 +45,17 @@
[c (in-list (if (directory-exists? d)
(directory-list d)
'()))])
+ : (Listof Path)
(build-path d c))])
(define cache (blueboxes-cache blueboxes-dirs #f))
(when populate? (populate-cache! cache))
cache)
+(: fetch-blueboxes-strs :
+ Tag
+ [#:blueboxes-cache Blueboxes-Cache]
+ ->
+ (U #f (List* String (Listof String))))
(define (fetch-blueboxes-strs tag #:blueboxes-cache [cache (make-blueboxes-cache #f)])
(define plain-strs (fetch-strs-for-single-tag tag cache))
(cond
@@ -49,10 +70,13 @@
(if constructor-strs (cdr constructor-strs) '()))]
[else plain-strs]))
+(: fetch-strs-for-single-tag : Tag Blueboxes-Cache -> (U #f (List* String (Listof String))))
(define (fetch-strs-for-single-tag tag cache)
(populate-cache! cache)
(for/or ([ent (in-list (blueboxes-cache-info-or-paths cache))])
- (check-and-update-bluebox-info! ent)
+ : (U #f (List* String (Listof String)))
+ (when (bluebox-info? ent)
+ (check-and-update-bluebox-info! ent))
(match ent
[(bluebox-info blueboxes.rktd offset tag-ht _)
(define offset+lens (and tag-ht (hash-ref tag-ht tag #f)))
@@ -62,30 +86,42 @@
(apply
append
(for/list ([offset+len (in-list offset+lens)])
+ : (Listof (Listof (U String EOF)))
(call-with-input-file blueboxes.rktd
- (λ (port)
+ (λ ([port : Input-Port])
(port-count-lines! port)
- (file-position port (+ (car offset+len) offset))
+ (file-position port (+ (car offset+len) (or offset 0)))
(for/list ([i (in-range (cdr offset+len))])
+ : (Listof (U String EOF))
(read-line port)))))))
(cond
- [(ormap eof-object? lines) #f]
+ [(not (andmap string? lines)) #f]
+ [(null? lines) #f]
[else lines])]
- [else #f])])))
+ [else #f])]
+ [_ (log-warning "expected bluebox-info?, given: ~v" ent)
+ #f])))
+(: fetch-blueboxes-method-tags : Symbol [#:blueboxes-cache Blueboxes-Cache] -> (Listof Method-Tag))
(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 ht (blueboxes-cache-method->tags cache))
+ (or (and ht (hash-ref ht sym (λ () '()))) '()))
+
+(define listof-path? (make-predicate (Listof Path)))
+(: populate-cache! : Blueboxes-Cache -> Void)
(define (populate-cache! cache)
(define cache-content (blueboxes-cache-info-or-paths cache))
- (when ((listof path?) cache-content)
+ (when (listof-path? cache-content)
(define the-cache (build-blueboxes-cache cache-content))
(define mtd-table (compute-methods-table the-cache))
(set-blueboxes-cache-method->tags! cache mtd-table)
(set-blueboxes-cache-info-or-paths! cache the-cache)))
+(: compute-methods-table : (Listof Bluebox-Info) -> (HashTable Symbol (Listof Method-Tag)))
(define (compute-methods-table lst)
+ (: meth-ht : (HashTable Symbol (Listof Method-Tag)))
(define meth-ht (make-hash))
(for ([a-bluebox-info (in-list lst)])
(match a-bluebox-info
@@ -94,19 +130,21 @@
(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 '()))))))]))
+ (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?))
+(: build-blueboxes-cache : (Listof Path) -> (Listof Bluebox-Info))
(define (build-blueboxes-cache blueboxes-dirs)
(filter
values
(for*/list ([doc-dir-name (in-list blueboxes-dirs)])
+ : (Listof Bluebox-Info)
(define blueboxes.rktd (build-path doc-dir-name "blueboxes.rktd"))
(define a-bluebox-info (bluebox-info blueboxes.rktd #f #f #f))
(populate-bluebox-info! a-bluebox-info)
a-bluebox-info)))
+(: check-and-update-bluebox-info! : bluebox-info -> Void)
(define (check-and-update-bluebox-info! a-bluebox-info)
(match a-bluebox-info
[(bluebox-info blueboxes.rktd offset tag-ht mod-time)
@@ -115,17 +153,18 @@
(not (mod-time . = . (file-or-directory-modify-seconds blueboxes.rktd)))))
(populate-bluebox-info! a-bluebox-info))]))
+(: populate-bluebox-info! : Bluebox-Info -> Void)
(define (populate-bluebox-info! a-bluebox-info)
(define blueboxes.rktd (bluebox-info-blueboxes.rktd a-bluebox-info))
(cond
[(file-exists? blueboxes.rktd)
(call-with-input-file blueboxes.rktd
- (λ (port)
+ (λ ([port : Input-Port])
(port-count-lines! port)
(define first-line (read-line port))
(define pos (file-position port))
(define desed
- (with-handlers ([exn:fail? (λ (x)
+ (with-handlers ([exn:fail? (λ ([x : exn:fail])
(log-warning "Failed to deserialize ~a: ~a"
x
(exn-message x))
@@ -135,8 +174,14 @@
(error 'build-blueboxes-cache
"blueboxes info didn't have the right shape: ~s"
candidate))
- candidate))
- (set-bluebox-info-offset! a-bluebox-info (and desed (+ (string->number first-line) pos)))
+ (cast candidate Blueboxes-Info-Hash)))
+ (define first-line-num (and (string? first-line) (string->number first-line)))
+ (cond
+ [(exact-nonnegative-integer? first-line-num)
+ (set-bluebox-info-offset! a-bluebox-info (+ first-line-num pos))]
+ [else
+ (log-warning "expected a string representing a Natuaral\n given: ~v"
+ first-line-num)])
(set-bluebox-info-tag-ht! a-bluebox-info desed)
(set-bluebox-info-mod-time! a-bluebox-info
(file-or-directory-modify-seconds blueboxes.rktd))))]
@@ -145,11 +190,9 @@
(set-bluebox-info-tag-ht! a-bluebox-info #f)
(set-bluebox-info-mod-time! a-bluebox-info #f)]))
-(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))
+(define-type Blueboxes-Info-Hash
+ (HashTable
+ Tag
+ (Listof (Pairof Natural
+ Natural))))
+
diff --git a/scribble-lib/scribble/valid-blueboxes-info.rkt b/scribble-lib/scribble/valid-blueboxes-info.rkt
@@ -0,0 +1,14 @@
+#lang racket/base
+
+(provide valid-blueboxes-info?)
+
+(require scribble/core racket/contract/base)
+
+(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))
