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

Convert unconstrained-domain-> to chaperones.

Browse Source
This commit is contained in:
Stevie Strickland 2010-06-11 17:28:59 -04:00
parent d92c4e44e2
commit 05e714881d
3 changed files with 53 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
collects/mzlib/private/contract-arrow.rkt
View File

@ -35,22 +35,33 @@
[(res-x ...) (generate-temporaries #'(rngs ...))])
#'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
(let ([proj-x (contract-projection rngs-x)] ...)
(define ctc
(make-contract
#:name
(build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...)
#:projection
(λ (blame)
(let ([p-app-x (proj-x blame)] ...)
(λ (val)
(if (procedure? val)
(make-contracted-function
(define name
(build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...))
(define (proj wrapper)
(λ (blame)
(let* ([p-app-x (proj-x blame)] ...
[res-checker (λ (res-x ...) (values (p-app-x res-x) ...))])
(λ (val)
(if (procedure? val)
(wrapper
val
(make-keyword-procedure
(λ (kwds kwd-vals . args)
(apply values res-checker kwd-vals args))
(λ args
(let-values ([(res-x ...) (apply val args)])
(values (p-app-x res-x) ...)))
ctc)
(raise-blame-error blame val "expected a procedure")))))
#:first-order procedure?))
(apply values res-checker args)))
proxy-prop:contracted ctc)
(raise-blame-error blame val "expected a procedure"))))))
(define ctc
(if (and (chaperone-contract? rngs-x) ...)
(make-chaperone-contract
#:name name
#:projection (proj chaperone-procedure)
#:first-order procedure?)
(make-contract
#:name name
#:projection (proj proxy-procedure)
#:first-order procedure?)))
ctc)))]))
(define (build--> name doms doms-rest rngs kwds quoted-kwds rng-any? func)

48
collects/racket/contract/private/arrow.rkt
View File

@ -60,29 +60,33 @@ v4 todo:
[(res-x ...) (generate-temporaries #'(rngs ...))])
#'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
(let ([proj-x (contract-projection rngs-x)] ...)
(define name
(build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...))
(define (projection wrapper)
(λ (blame)
(let* ([p-app-x (proj-x blame)] ...
[res-checker (λ (res-x ...) (values (p-app-x res-x) ...))])
(λ (val)
(unless (procedure? val)
(raise-blame-error blame val "expected a procedure, got ~v" val))
(wrapper
val
(make-keyword-procedure
(λ (kwds kwd-vals . args)
(apply values res-checker kwd-vals args))
(λ args
(apply values res-checker args)))
proxy-prop:contracted ctc)))))
(define ctc
(make-contract
#:name
(build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...)
#:projection
(λ (blame)
(let ([p-app-x (proj-x blame)] ...)
(λ (val)
(if (procedure? val)
(make-contracted-function
(make-keyword-procedure
(λ (kwds kwd-vals . args)
(let-values ([(res-x ...) (keyword-apply val kwds kwd-vals args)])
(values (p-app-x res-x) ...)))
(λ args
(let-values ([(res-x ...) (apply val args)])
(values (p-app-x res-x) ...))))
ctc)
(raise-blame-error blame
val
"expected a procedure")))))
#:first-order
procedure?))
(if (and (chaperone-contract? rngs-x) ...)
(make-chaperone-contract
#:name name
#:projection (projection chaperone-procedure)
#:first-order procedure?)
(make-contract
#:name name
#:projection (projection proxy-procedure)
#:first-order procedure?)))
ctc)))]))

1
collects/racket/contract/private/base.rkt
View File

@ -51,6 +51,7 @@ improve method arity mismatch contract violation error messages?
(if (and name
(not (parameter? new-val)) ;; when PR 11221 is fixed, remove this line
(procedure? new-val)
(not (proxy-of? new-val v)) ;; proxies/chaperones handle this fine
(not (eq? name (object-name new-val))))
(let ([name (if (symbol? name)
name