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

Convert unconstrained-domain-> to chaperones.

Browse Source 
original commit: 05e714881d95f2347bd71899acc20f95d726e7cc
This commit is contained in:
Stevie Strickland 2010-06-11 17:28:59 -04:00
parent f3f84db494
commit 0ddfa81da3
1 changed files with 26 additions and 15 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)