suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

convert blueboxes.rkt to typed racket

Browse Source
This commit is contained in:
AlexKnauth 2015-06-28 00:31:49 -04:00 committed by Robby Findler
parent b812869d3e
commit b1d380d4b5
3 changed files with 103 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
scribble-lib/info.rkt
View File

@ -8,11 +8,13 @@
"scribble-text-lib" "scribble-text-lib"
"scribble-html-lib" "scribble-html-lib"
"planet-lib" ; used dynamically "planet-lib" ; used dynamically
"net-lib" "net-lib"
"at-exp-lib" "at-exp-lib"
"draw-lib" "draw-lib"
"syntax-color-lib" "syntax-color-lib"
"sandbox-lib")) "sandbox-lib"
"typed-racket-lib"
))
(define build-deps '("rackunit-lib" (define build-deps '("rackunit-lib"
"eli-tester")) "eli-tester"))

127
scribble-lib/scribble/blueboxes.rkt
View File

@ -1,28 +1,43 @@
#lang racket/base #lang typed/racket/base
(require setup/dirs (require racket/match)
racket/serialize (require/typed setup/dirs [get-doc-search-dirs (-> (Listof Path))])
racket/contract (require/typed racket/serialize [deserialize (Any -> Any)])
racket/match (require/typed scribble/core [#:opaque Tag tag?])
scribble/core (require/typed scribble/tag
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 (provide fetch-blueboxes-strs
(contract-out make-blueboxes-cache
[fetch-blueboxes-strs (->* (tag?) (#:blueboxes-cache blueboxes-cache?) blueboxes-cache?
(or/c #f (non-empty-listof string?)))] fetch-blueboxes-method-tags
[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?))]))
(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) (define-type Blueboxes-Cache blueboxes-cache)
;; tag-ht : (or/c valid-blueboxes-info? #f) (struct blueboxes-cache
;; mod-time : (or/c exact-nonnegative-integer? #f) ([info-or-paths : (U (Listof Path) (Listof Bluebox-Info))]
(struct bluebox-info (blueboxes.rktd [offset #:mutable] [tag-ht #:mutable] [mod-time #:mutable])) [method->tags : (U (HashTable Symbol (Listof Method-Tag)) #f)])
#:mutable)
(struct blueboxes-cache (info-or-paths method->tags) #:mutable)
(: make-blueboxes-cache :
Boolean
[#:blueboxes-dirs (Listof Path)]
->
Blueboxes-Cache)
(define (make-blueboxes-cache (define (make-blueboxes-cache
populate? populate?
#:blueboxes-dirs #:blueboxes-dirs
@ -30,11 +45,17 @@
[c (in-list (if (directory-exists? d) [c (in-list (if (directory-exists? d)
(directory-list d) (directory-list d)
'()))]) '()))])
: (Listof Path)
(build-path d c))]) (build-path d c))])
(define cache (blueboxes-cache blueboxes-dirs #f)) (define cache (blueboxes-cache blueboxes-dirs #f))
(when populate? (populate-cache! cache)) (when populate? (populate-cache! 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 (fetch-blueboxes-strs tag #:blueboxes-cache [cache (make-blueboxes-cache #f)])
(define plain-strs (fetch-strs-for-single-tag tag cache)) (define plain-strs (fetch-strs-for-single-tag tag cache))
(cond (cond
@ -49,10 +70,13 @@
(if constructor-strs (cdr constructor-strs) '()))] (if constructor-strs (cdr constructor-strs) '()))]
[else plain-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) (define (fetch-strs-for-single-tag tag cache)
(populate-cache! cache) (populate-cache! cache)
(for/or ([ent (in-list (blueboxes-cache-info-or-paths 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 (match ent
[(bluebox-info blueboxes.rktd offset tag-ht _) [(bluebox-info blueboxes.rktd offset tag-ht _)
(define offset+lens (and tag-ht (hash-ref tag-ht tag #f))) (define offset+lens (and tag-ht (hash-ref tag-ht tag #f)))
@ -62,30 +86,42 @@
(apply (apply
append append
(for/list ([offset+len (in-list offset+lens)]) (for/list ([offset+len (in-list offset+lens)])
: (Listof (Listof (U String EOF)))
(call-with-input-file blueboxes.rktd (call-with-input-file blueboxes.rktd
(λ (port) (λ ([port : Input-Port])
(port-count-lines! 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))]) (for/list ([i (in-range (cdr offset+len))])
: (Listof (U String EOF))
(read-line port))))))) (read-line port)))))))
(cond (cond
[(ormap eof-object? lines) #f] [(not (andmap string? lines)) #f]
[(null? lines) #f]
[else lines])] [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)]) (define (fetch-blueboxes-method-tags sym #:blueboxes-cache [cache (make-blueboxes-cache #f)])
(populate-cache! cache) (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 (populate-cache! cache)
(define cache-content (blueboxes-cache-info-or-paths 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 the-cache (build-blueboxes-cache cache-content))
(define mtd-table (compute-methods-table the-cache)) (define mtd-table (compute-methods-table the-cache))
(set-blueboxes-cache-method->tags! cache mtd-table) (set-blueboxes-cache-method->tags! cache mtd-table)
(set-blueboxes-cache-info-or-paths! cache the-cache))) (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) (define (compute-methods-table lst)
(: meth-ht : (HashTable Symbol (Listof Method-Tag)))
(define meth-ht (make-hash)) (define meth-ht (make-hash))
(for ([a-bluebox-info (in-list lst)]) (for ([a-bluebox-info (in-list lst)])
(match a-bluebox-info (match a-bluebox-info
@ -94,19 +130,21 @@
(for ([(tag val) (in-hash tag-ht)]) (for ([(tag val) (in-hash tag-ht)])
(when (method-tag? tag) (when (method-tag? tag)
(define-values (class/intf meth) (get-class/interface-and-method 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) 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) (define (build-blueboxes-cache blueboxes-dirs)
(filter (filter
values values
(for*/list ([doc-dir-name (in-list blueboxes-dirs)]) (for*/list ([doc-dir-name (in-list blueboxes-dirs)])
: (Listof Bluebox-Info)
(define blueboxes.rktd (build-path doc-dir-name "blueboxes.rktd")) (define blueboxes.rktd (build-path doc-dir-name "blueboxes.rktd"))
(define a-bluebox-info (bluebox-info blueboxes.rktd #f #f #f)) (define a-bluebox-info (bluebox-info blueboxes.rktd #f #f #f))
(populate-bluebox-info! a-bluebox-info) (populate-bluebox-info! a-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) (define (check-and-update-bluebox-info! a-bluebox-info)
(match a-bluebox-info (match a-bluebox-info
[(bluebox-info blueboxes.rktd offset tag-ht mod-time) [(bluebox-info blueboxes.rktd offset tag-ht mod-time)
@ -115,17 +153,18 @@
(not (mod-time . = . (file-or-directory-modify-seconds blueboxes.rktd))))) (not (mod-time . = . (file-or-directory-modify-seconds blueboxes.rktd)))))
(populate-bluebox-info! a-bluebox-info))])) (populate-bluebox-info! a-bluebox-info))]))
(: populate-bluebox-info! : Bluebox-Info -> Void)
(define (populate-bluebox-info! a-bluebox-info) (define (populate-bluebox-info! a-bluebox-info)
(define blueboxes.rktd (bluebox-info-blueboxes.rktd a-bluebox-info)) (define blueboxes.rktd (bluebox-info-blueboxes.rktd a-bluebox-info))
(cond (cond
[(file-exists? blueboxes.rktd) [(file-exists? blueboxes.rktd)
(call-with-input-file blueboxes.rktd (call-with-input-file blueboxes.rktd
(λ (port) (λ ([port : Input-Port])
(port-count-lines! port) (port-count-lines! port)
(define first-line (read-line port)) (define first-line (read-line port))
(define pos (file-position port)) (define pos (file-position port))
(define desed (define desed
(with-handlers ([exn:fail? (λ (x) (with-handlers ([exn:fail? (λ ([x : exn:fail])
(log-warning "Failed to deserialize ~a: ~a" (log-warning "Failed to deserialize ~a: ~a"
x x
(exn-message x)) (exn-message x))
@ -135,8 +174,14 @@
(error 'build-blueboxes-cache (error 'build-blueboxes-cache
"blueboxes info didn't have the right shape: ~s" "blueboxes info didn't have the right shape: ~s"
candidate)) candidate))
candidate)) (cast candidate Blueboxes-Info-Hash)))
(set-bluebox-info-offset! a-bluebox-info (and desed (+ (string->number first-line) pos))) (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-tag-ht! a-bluebox-info desed)
(set-bluebox-info-mod-time! a-bluebox-info (set-bluebox-info-mod-time! a-bluebox-info
(file-or-directory-modify-seconds blueboxes.rktd))))] (file-or-directory-modify-seconds blueboxes.rktd))))]
@ -145,11 +190,9 @@
(set-bluebox-info-tag-ht! a-bluebox-info #f) (set-bluebox-info-tag-ht! a-bluebox-info #f)
(set-bluebox-info-mod-time! a-bluebox-info #f)])) (set-bluebox-info-mod-time! a-bluebox-info #f)]))
(define valid-blueboxes-info? (define-type Blueboxes-Info-Hash
(hash/c (HashTable
tag? Tag
(listof (cons/dc [hd exact-nonnegative-integer?] (Listof (Pairof Natural
[tl (hd) (and/c exact-nonnegative-integer? Natural))))
(>/c hd))]
#:flat))
#:flat? #t))

14
scribble-lib/scribble/valid-blueboxes-info.rkt Normal file
View File

@ -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))