suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Ported more code to use new contract bindings.

Browse Source 
svn: r17727
This commit is contained in:
Carl Eastlund 2010-01-19 01:01:28 +00:00
parent a03454ec69
commit 2bad47fd0f
6 changed files with 49 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/mzlib/private/contract-object.ss
View File

@ -340,10 +340,12 @@
(list methods ...) (list methods ...)
'(field-name ...) '(field-name ...)
#t)]) #t)])
(make-proj-contract (simple-contract
#:name
`(object-contract `(object-contract
,(build-compound-type-name 'method-name method-ctc-var) ... ,(build-compound-type-name 'method-name method-ctc-var) ...
,(build-compound-type-name 'field 'field-name field-ctc-var) ...) ,(build-compound-type-name 'field 'field-name field-ctc-var) ...)
#:projection
(lambda (blame) (lambda (blame)
(let ([method/app-var (method-var blame)] (let ([method/app-var (method-var blame)]
... ...
@ -369,8 +371,7 @@
val val
(method/app-var (vector-ref vtable (hash-ref method-ht 'method-name))) ... (method/app-var (vector-ref vtable (hash-ref method-ht 'method-name))) ...
(field/app-var (get-field field-name val)) ... (field/app-var (get-field field-name val)) ...
)))))) )))))))))))))]))))
#f)))))))]))))
(define (check-object val blame) (define (check-object val blame)

5
collects/mzlib/private/unit-contract.ss
View File

@ -132,7 +132,8 @@
export-tagged-infos)]) export-tagged-infos)])
(quasisyntax/loc stx (quasisyntax/loc stx
(begin (begin
(make-proj-contract (simple-contract
#:name
(list 'unit/c (list 'unit/c
(cons 'import (cons 'import
(list (cons 'isig (list (cons 'isig
@ -144,6 +145,7 @@
(map list (list 'e.x ...) (map list (list 'e.x ...)
(build-compound-type-name 'e.c ...))) (build-compound-type-name 'e.c ...)))
...))) ...)))
#:projection
(λ (blame) (λ (blame)
(λ (unit-tmp) (λ (unit-tmp)
(unless (unit? unit-tmp) (unless (unit? unit-tmp)
@ -179,6 +181,7 @@
export-sigs export-sigs
contract-table contract-table
#'blame))))))) #'blame)))))))
#:first-order
(λ (v) (λ (v)
(and (unit? v) (and (unit? v)
(with-handlers ([exn:fail:contract? (λ () #f)]) (with-handlers ([exn:fail:contract? (λ () #f)])

29
collects/unstable/contract.ss
View File

@ -38,26 +38,29 @@
(if (predicate x) (then-pred x) (else-pred x))) (if (predicate x) (then-pred x) (else-pred x)))
(flat-named-contract name pred)) (flat-named-contract name pred))
;; ho contract ;; ho contract
(let ([then-proj ((proj-get then-ctc) then-ctc)] (let ([then-proj (contract-projection then-ctc)]
[then-fo ((first-order-get then-ctc) then-ctc)] [then-fo (contract-first-order then-ctc)]
[else-proj ((proj-get else-ctc) else-ctc)] [else-proj (contract-projection else-ctc)]
[else-fo ((first-order-get else-ctc) else-ctc)]) [else-fo (contract-first-order else-ctc)])
(define ((proj pos neg srcinfo name pos?) x) (define ((proj blame) x)
(if (predicate x) (if (predicate x)
((then-proj pos neg srcinfo name pos?) x) ((then-proj blame) x)
((else-proj pos neg srcinfo name pos?) x))) ((else-proj blame) x)))
(make-proj-contract (simple-contract
name #:name name
proj #:projection proj
#:first-order
(lambda (x) (if (predicate x) (then-fo x) (else-fo x)))))))) (lambda (x) (if (predicate x) (then-fo x) (else-fo x))))))))
(define (rename-contract ctc name) (define (rename-contract ctc name)
(let ([ctc (coerce-contract 'rename-contract ctc)]) (let ([ctc (coerce-contract 'rename-contract ctc)])
(if (flat-contract? ctc) (if (flat-contract? ctc)
(flat-named-contract name (flat-contract-predicate ctc)) (flat-named-contract name (flat-contract-predicate ctc))
(let* ([ctc-fo ((first-order-get ctc) ctc)] (let* ([ctc-fo (contract-first-order ctc)]
[proj ((proj-get ctc) ctc)]) [proj (contract-projection ctc)])
(make-proj-contract name proj ctc-fo))))) (simple-contract #:name name
#:projection proj
#:first-order ctc-fo)))))
(provide/contract (provide/contract
[non-empty-string/c contract?] [non-empty-string/c contract?]

10
collects/web-server/private/xexpr.ss
View File

@ -12,9 +12,10 @@
[pretty-xexpr/c contract?]) [pretty-xexpr/c contract?])
(define pretty-xexpr/c (define pretty-xexpr/c
(make-proj-contract (simple-contract
'pretty-xexpr/c #:name 'pretty-xexpr/c
(lambda (pos neg src-info name) #:projection
(lambda (blame)
(lambda (val) (lambda (val)
(define marks (current-continuation-marks)) (define marks (current-continuation-marks))
(with-handlers ([exn:fail:contract? (with-handlers ([exn:fail:contract?
@ -25,8 +26,7 @@
marks marks
`(span ,(drop-after "Context:\n" (exn-message exn)) "\n" `(span ,(drop-after "Context:\n" (exn-message exn)) "\n"
,(make-cdata #f #f (format-xexpr/errors val))))))]) ,(make-cdata #f #f (format-xexpr/errors val))))))])
(contract xexpr/c val pos neg src-info)))) (((contract-projection xexpr/c) blame) val))))))
(lambda (v) #t)))
(define (drop-after delim str) (define (drop-after delim str)
(match (regexp-match-positions (regexp-quote delim) str) (match (regexp-match-positions (regexp-quote delim) str)

23
collects/web-server/servlet/setup.ss
View File

@ -128,10 +128,7 @@
[neg-blame 'web-server] [neg-blame 'web-server]
[pos-blame path-sym] [pos-blame path-sym]
[module-name `(file ,path-string)] [module-name `(file ,path-string)]
[mk-loc [loc (make-srcloc a-path #f #f #f #f)]
(lambda (name)
(list (make-srcloc a-path #f #f #f #f)
name))]
[s (load/use-compiled a-path)]) [s (load/use-compiled a-path)])
(cond (cond
[(void? s) [(void? s)
@ -139,47 +136,47 @@
(contract (symbols 'v1 'v2 'stateless) (contract (symbols 'v1 'v2 'stateless)
(dynamic-require module-name 'interface-version) (dynamic-require module-name 'interface-version)
pos-blame neg-blame pos-blame neg-blame
(mk-loc "interface-version"))]) loc "interface-version")])
(case version (case version
[(v1) [(v1)
(let ([timeout (contract number? (let ([timeout (contract number?
(dynamic-require module-name 'timeout) (dynamic-require module-name 'timeout)
pos-blame neg-blame pos-blame neg-blame
(mk-loc "timeout"))] loc "timeout")]
[start (contract (request? . -> . response/c) [start (contract (request? . -> . response/c)
(dynamic-require module-name 'start) (dynamic-require module-name 'start)
pos-blame neg-blame pos-blame neg-blame
(mk-loc "start"))]) loc "start")])
(make-v1.servlet (directory-part a-path) timeout start))] (make-v1.servlet (directory-part a-path) timeout start))]
[(v2) [(v2)
(let ([start (contract (request? . -> . response/c) (let ([start (contract (request? . -> . response/c)
(dynamic-require module-name 'start) (dynamic-require module-name 'start)
pos-blame neg-blame pos-blame neg-blame
(mk-loc "start"))] loc "start")]
[manager (contract manager? [manager (contract manager?
(dynamic-require module-name 'manager) (dynamic-require module-name 'manager)
pos-blame neg-blame pos-blame neg-blame
(mk-loc "manager"))]) loc "manager")])
(make-v2.servlet (directory-part a-path) manager start))] (make-v2.servlet (directory-part a-path) manager start))]
[(stateless) [(stateless)
(let ([start (contract (request? . -> . response/c) (let ([start (contract (request? . -> . response/c)
(dynamic-require module-name 'start) (dynamic-require module-name 'start)
pos-blame neg-blame pos-blame neg-blame
(mk-loc "start"))] loc "start")]
[manager (contract manager? [manager (contract manager?
(dynamic-require module-name 'manager (dynamic-require module-name 'manager
(lambda () (create-none-manager (lambda (req) (error "No continuations!"))))) (lambda () (create-none-manager (lambda (req) (error "No continuations!")))))
pos-blame neg-blame pos-blame neg-blame
(mk-loc "manager"))] loc "manager")]
[stuffer (contract (stuffer/c serializable? bytes?) [stuffer (contract (stuffer/c serializable? bytes?)
(dynamic-require module-name 'stuffer (lambda () default-stuffer)) (dynamic-require module-name 'stuffer (lambda () default-stuffer))
pos-blame neg-blame pos-blame neg-blame
(mk-loc "stuffer"))]) loc "stuffer")])
(make-stateless.servlet (directory-part a-path) stuffer manager start))]))] (make-stateless.servlet (directory-part a-path) stuffer manager start))]))]
[else [else
(make-v1.servlet (directory-part a-path) timeouts-default-servlet (make-v1.servlet (directory-part a-path) timeouts-default-servlet
(v0.response->v1.lambda (v0.response->v1.lambda
(contract response/c s (contract response/c s
pos-blame neg-blame pos-blame neg-blame
(mk-loc path-string)) loc path-string)
a-path))]))))) a-path))])))))

22
collects/web-server/stuffers/stuffer.ss
View File

@ -3,22 +3,20 @@
(define-struct stuffer (in out)) (define-struct stuffer (in out))
(define (stuffer/c dom rng) (define (stuffer/c dom rng)
(define in (dom . -> . rng)) (define in (dom . -> . rng))
(define in-proc (contract-proc in)) (define in-proc (contract-projection in))
(define out (rng . -> . dom)) (define out (rng . -> . dom))
(define out-proc (contract-proc out)) (define out-proc (contract-projection out))
(make-proj-contract (simple-contract
(build-compound-type-name 'stuffer/c in out) #:name (build-compound-type-name 'stuffer/c in out)
(λ (pos-blame neg-blame src-info orig-str positive-position?) #:projection
(define in-app (in-proc pos-blame neg-blame src-info orig-str positive-position?)) (λ (blame)
(define out-app (out-proc pos-blame neg-blame src-info orig-str positive-position?)) (define in-app (in-proc blame))
(define out-app (out-proc blame))
(λ (val) (λ (val)
(unless (stuffer? val) (unless (stuffer? val)
(raise-contract-error (raise-blame-error
blame
val val
src-info
pos-blame
'ignored
orig-str
"expected <stuffer>, given: ~e" "expected <stuffer>, given: ~e"
val)) val))
(make-stuffer (make-stuffer