From b1d380d4b59197b1913b1a83747b68f9f6135ec2 Mon Sep 17 00:00:00 2001 From: AlexKnauth Date: Sun, 28 Jun 2015 00:31:49 -0400 Subject: [PATCH] convert blueboxes.rkt to typed racket --- scribble-lib/info.rkt | 6 +- scribble-lib/scribble/blueboxes.rkt | 127 ++++++++++++------ .../scribble/valid-blueboxes-info.rkt | 14 ++ 3 files changed, 103 insertions(+), 44 deletions(-) create mode 100644 scribble-lib/scribble/valid-blueboxes-info.rkt diff --git a/scribble-lib/info.rkt b/scribble-lib/info.rkt index b62d64a5..60688778 100644 --- 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 index 68005361..5e42a123 100644 --- 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 new file mode 100644 index 00000000..7b657e0d --- /dev/null +++ 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))