suzanne.soy/scribble-enhanced
1
0
Fork 0
Code Issues 1 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-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"))

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

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

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