Ported more code to use new contract bindings.
svn: r17727
This commit is contained in:
Carl Eastlund
parent
a03454ec69
commit
2bad47fd0f
|
|
@ -340,10 +340,12 @@
|
|||
(list methods ...)
|
||||
'(field-name ...)
|
||||
#t)])
|
||||
(make-proj-contract
|
||||
(simple-contract
|
||||
#:name
|
||||
`(object-contract
|
||||
,(build-compound-type-name 'method-name method-ctc-var) ...
|
||||
,(build-compound-type-name 'field 'field-name field-ctc-var) ...)
|
||||
#:projection
|
||||
(lambda (blame)
|
||||
(let ([method/app-var (method-var blame)]
|
||||
...
|
||||
|
|
@ -369,8 +371,7 @@
|
|||
val
|
||||
(method/app-var (vector-ref vtable (hash-ref method-ht 'method-name))) ...
|
||||
(field/app-var (get-field field-name val)) ...
|
||||
))))))
|
||||
#f)))))))]))))
|
||||
)))))))))))))]))))
|
||||
|
||||
|
||||
(define (check-object val blame)
|
||||
|
|
|
|||
|
|
@ -132,7 +132,8 @@
|
|||
export-tagged-infos)])
|
||||
(quasisyntax/loc stx
|
||||
(begin
|
||||
(make-proj-contract
|
||||
(simple-contract
|
||||
#:name
|
||||
(list 'unit/c
|
||||
(cons 'import
|
||||
(list (cons 'isig
|
||||
|
|
@ -144,6 +145,7 @@
|
|||
(map list (list 'e.x ...)
|
||||
(build-compound-type-name 'e.c ...)))
|
||||
...)))
|
||||
#:projection
|
||||
(λ (blame)
|
||||
(λ (unit-tmp)
|
||||
(unless (unit? unit-tmp)
|
||||
|
|
@ -179,6 +181,7 @@
|
|||
export-sigs
|
||||
contract-table
|
||||
#'blame)))))))
|
||||
#:first-order
|
||||
(λ (v)
|
||||
(and (unit? v)
|
||||
(with-handlers ([exn:fail:contract? (λ () #f)])
|
||||
|
|
|
|||
|
|
@ -38,26 +38,29 @@
|
|||
(if (predicate x) (then-pred x) (else-pred x)))
|
||||
(flat-named-contract name pred))
|
||||
;; ho contract
|
||||
(let ([then-proj ((proj-get then-ctc) then-ctc)]
|
||||
[then-fo ((first-order-get then-ctc) then-ctc)]
|
||||
[else-proj ((proj-get else-ctc) else-ctc)]
|
||||
[else-fo ((first-order-get else-ctc) else-ctc)])
|
||||
(define ((proj pos neg srcinfo name pos?) x)
|
||||
(let ([then-proj (contract-projection then-ctc)]
|
||||
[then-fo (contract-first-order then-ctc)]
|
||||
[else-proj (contract-projection else-ctc)]
|
||||
[else-fo (contract-first-order else-ctc)])
|
||||
(define ((proj blame) x)
|
||||
(if (predicate x)
|
||||
((then-proj pos neg srcinfo name pos?) x)
|
||||
((else-proj pos neg srcinfo name pos?) x)))
|
||||
(make-proj-contract
|
||||
name
|
||||
proj
|
||||
((then-proj blame) x)
|
||||
((else-proj blame) x)))
|
||||
(simple-contract
|
||||
#:name name
|
||||
#:projection proj
|
||||
#:first-order
|
||||
(lambda (x) (if (predicate x) (then-fo x) (else-fo x))))))))
|
||||
|
||||
(define (rename-contract ctc name)
|
||||
(let ([ctc (coerce-contract 'rename-contract ctc)])
|
||||
(if (flat-contract? ctc)
|
||||
(flat-named-contract name (flat-contract-predicate ctc))
|
||||
(let* ([ctc-fo ((first-order-get ctc) ctc)]
|
||||
[proj ((proj-get ctc) ctc)])
|
||||
(make-proj-contract name proj ctc-fo)))))
|
||||
(let* ([ctc-fo (contract-first-order ctc)]
|
||||
[proj (contract-projection ctc)])
|
||||
(simple-contract #:name name
|
||||
#:projection proj
|
||||
#:first-order ctc-fo)))))
|
||||
|
||||
(provide/contract
|
||||
[non-empty-string/c contract?]
|
||||
|
|
|
|||
|
|
@ -12,9 +12,10 @@
|
|||
[pretty-xexpr/c contract?])
|
||||
|
||||
(define pretty-xexpr/c
|
||||
(make-proj-contract
|
||||
'pretty-xexpr/c
|
||||
(lambda (pos neg src-info name)
|
||||
(simple-contract
|
||||
#:name 'pretty-xexpr/c
|
||||
#:projection
|
||||
(lambda (blame)
|
||||
(lambda (val)
|
||||
(define marks (current-continuation-marks))
|
||||
(with-handlers ([exn:fail:contract?
|
||||
|
|
@ -25,8 +26,7 @@
|
|||
marks
|
||||
`(span ,(drop-after "Context:\n" (exn-message exn)) "\n"
|
||||
,(make-cdata #f #f (format-xexpr/errors val))))))])
|
||||
(contract xexpr/c val pos neg src-info))))
|
||||
(lambda (v) #t)))
|
||||
(((contract-projection xexpr/c) blame) val))))))
|
||||
|
||||
(define (drop-after delim str)
|
||||
(match (regexp-match-positions (regexp-quote delim) str)
|
||||
|
|
|
|||
|
|
@ -128,10 +128,7 @@
|
|||
[neg-blame 'web-server]
|
||||
[pos-blame path-sym]
|
||||
[module-name `(file ,path-string)]
|
||||
[mk-loc
|
||||
(lambda (name)
|
||||
(list (make-srcloc a-path #f #f #f #f)
|
||||
name))]
|
||||
[loc (make-srcloc a-path #f #f #f #f)]
|
||||
[s (load/use-compiled a-path)])
|
||||
(cond
|
||||
[(void? s)
|
||||
|
|
@ -139,47 +136,47 @@
|
|||
(contract (symbols 'v1 'v2 'stateless)
|
||||
(dynamic-require module-name 'interface-version)
|
||||
pos-blame neg-blame
|
||||
(mk-loc "interface-version"))])
|
||||
loc "interface-version")])
|
||||
(case version
|
||||
[(v1)
|
||||
(let ([timeout (contract number?
|
||||
(dynamic-require module-name 'timeout)
|
||||
pos-blame neg-blame
|
||||
(mk-loc "timeout"))]
|
||||
loc "timeout")]
|
||||
[start (contract (request? . -> . response/c)
|
||||
(dynamic-require module-name 'start)
|
||||
pos-blame neg-blame
|
||||
(mk-loc "start"))])
|
||||
loc "start")])
|
||||
(make-v1.servlet (directory-part a-path) timeout start))]
|
||||
[(v2)
|
||||
(let ([start (contract (request? . -> . response/c)
|
||||
(dynamic-require module-name 'start)
|
||||
pos-blame neg-blame
|
||||
(mk-loc "start"))]
|
||||
loc "start")]
|
||||
[manager (contract manager?
|
||||
(dynamic-require module-name 'manager)
|
||||
pos-blame neg-blame
|
||||
(mk-loc "manager"))])
|
||||
loc "manager")])
|
||||
(make-v2.servlet (directory-part a-path) manager start))]
|
||||
[(stateless)
|
||||
(let ([start (contract (request? . -> . response/c)
|
||||
(dynamic-require module-name 'start)
|
||||
pos-blame neg-blame
|
||||
(mk-loc "start"))]
|
||||
loc "start")]
|
||||
[manager (contract manager?
|
||||
(dynamic-require module-name 'manager
|
||||
(lambda () (create-none-manager (lambda (req) (error "No continuations!")))))
|
||||
pos-blame neg-blame
|
||||
(mk-loc "manager"))]
|
||||
loc "manager")]
|
||||
[stuffer (contract (stuffer/c serializable? bytes?)
|
||||
(dynamic-require module-name 'stuffer (lambda () default-stuffer))
|
||||
pos-blame neg-blame
|
||||
(mk-loc "stuffer"))])
|
||||
loc "stuffer")])
|
||||
(make-stateless.servlet (directory-part a-path) stuffer manager start))]))]
|
||||
[else
|
||||
(make-v1.servlet (directory-part a-path) timeouts-default-servlet
|
||||
(v0.response->v1.lambda
|
||||
(contract response/c s
|
||||
pos-blame neg-blame
|
||||
(mk-loc path-string))
|
||||
loc path-string)
|
||||
a-path))])))))
|
||||
|
|
|
|||
|
|
@ -3,22 +3,20 @@
|
|||
(define-struct stuffer (in out))
|
||||
(define (stuffer/c dom rng)
|
||||
(define in (dom . -> . rng))
|
||||
(define in-proc (contract-proc in))
|
||||
(define in-proc (contract-projection in))
|
||||
(define out (rng . -> . dom))
|
||||
(define out-proc (contract-proc out))
|
||||
(make-proj-contract
|
||||
(build-compound-type-name 'stuffer/c in out)
|
||||
(λ (pos-blame neg-blame src-info orig-str positive-position?)
|
||||
(define in-app (in-proc pos-blame neg-blame src-info orig-str positive-position?))
|
||||
(define out-app (out-proc pos-blame neg-blame src-info orig-str positive-position?))
|
||||
(define out-proc (contract-projection out))
|
||||
(simple-contract
|
||||
#:name (build-compound-type-name 'stuffer/c in out)
|
||||
#:projection
|
||||
(λ (blame)
|
||||
(define in-app (in-proc blame))
|
||||
(define out-app (out-proc blame))
|
||||
(λ (val)
|
||||
(unless (stuffer? val)
|
||||
(raise-contract-error
|
||||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
src-info
|
||||
pos-blame
|
||||
'ignored
|
||||
orig-str
|
||||
"expected <stuffer>, given: ~e"
|
||||
val))
|
||||
(make-stuffer
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user