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

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

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

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

@ -60,29 +60,33 @@ v4 todo:
[(res-x ...) (generate-temporaries #'(rngs ...))]) [(res-x ...) (generate-temporaries #'(rngs ...))])
#'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...) #'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
(let ([proj-x (contract-projection rngs-x)] ...) (let ([proj-x (contract-projection rngs-x)] ...)
(define ctc (define name
(make-contract (build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...))
#:name (define (projection wrapper)
(build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...)
#:projection
(λ (blame) (λ (blame)
(let ([p-app-x (proj-x blame)] ...) (let* ([p-app-x (proj-x blame)] ...
[res-checker (λ (res-x ...) (values (p-app-x res-x) ...))])
(λ (val) (λ (val)
(if (procedure? val) (unless (procedure? val)
(make-contracted-function (raise-blame-error blame val "expected a procedure, got ~v" val))
(wrapper
val
(make-keyword-procedure (make-keyword-procedure
(λ (kwds kwd-vals . args) (λ (kwds kwd-vals . args)
(let-values ([(res-x ...) (keyword-apply val kwds kwd-vals args)]) (apply values res-checker kwd-vals args))
(values (p-app-x res-x) ...)))
(λ args (λ args
(let-values ([(res-x ...) (apply val args)]) (apply values res-checker args)))
(values (p-app-x res-x) ...)))) proxy-prop:contracted ctc)))))
ctc) (define ctc
(raise-blame-error blame (if (and (chaperone-contract? rngs-x) ...)
val (make-chaperone-contract
"expected a procedure"))))) #:name name
#:first-order #:projection (projection chaperone-procedure)
procedure?)) #:first-order procedure?)
(make-contract
#:name name
#:projection (projection proxy-procedure)
#:first-order procedure?)))
ctc)))])) 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 (if (and name
(not (parameter? new-val)) ;; when PR 11221 is fixed, remove this line (not (parameter? new-val)) ;; when PR 11221 is fixed, remove this line
(procedure? new-val) (procedure? new-val)
(not (proxy-of? new-val v)) ;; proxies/chaperones handle this fine
(not (eq? name (object-name new-val)))) (not (eq? name (object-name new-val))))
(let ([name (if (symbol? name) (let ([name (if (symbol? name)
name name