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

Refactor out new has-contract?/value-contract functionality so that it's

Browse Source 
the responsibility of the (higher-order) contract to add the contract
(plus possibly more in the future) to the wrapped value.

svn: r18469

original commit: bf60da75e179c2b2ecd9c09f0f7aadda629d95b5
This commit is contained in:
Stevie Strickland 2010-03-04 21:10:44 +00:00
parent 2b7121ca81
commit d889d9de71
1 changed files with 28 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
collects/mzlib/private/contract-arrow.ss
View File

@ -22,6 +22,10 @@
opt->*
unconstrained-domain->)
(define-struct contracted-function (proc ctc)
#:property prop:procedure 0
#:property prop:contracted 1)
(define-syntax (unconstrained-domain-> stx)
(syntax-case stx ()
[(_ rngs ...)
@ -31,19 +35,23 @@
[(res-x ...) (generate-temporaries #'(rngs ...))])
#'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
(let ([proj-x (contract-projection rngs-x)] ...)
(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)
(λ args
(let-values ([(res-x ...) (apply val args)])
(values (p-app-x res-x) ...)))
(raise-blame-error blame val "expected a procedure")))))
#:first-order procedure?))))]))
(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
(λ 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?))
ctc)))]))
(define (build--> name doms doms-rest rngs kwds quoted-kwds rng-any? func)
(let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)]
@ -88,6 +96,7 @@
(if has-rest?
(check-procedure/more val dom-length '() mandatory-keywords blame)
(check-procedure val dom-length 0 '() mandatory-keywords blame)))
ctc
(append partial-doms partial-ranges partial-kwds))))))
#:name
@ -263,10 +272,10 @@
[use-any? use-any?])
(with-syntax ([outer-lambda
(syntax
(lambda (chk dom-names ... rng-names ... kwd-names ...)
(lambda (chk ctc dom-names ... rng-names ... kwd-names ...)
(lambda (val)
(chk val)
inner-lambda)))])
(make-contracted-function inner-lambda ctc))))])
(values
(syntax (build--> '->
(list dom-ctcs ...)
@ -323,10 +332,10 @@
(syntax (lambda args body))))])
(with-syntax ([outer-lambda
(syntax
(lambda (chk dom-x ... rst-x rng-x ... dom-kwd-ctc-id ...)
(lambda (chk ctc dom-x ... rst-x rng-x ... dom-kwd-ctc-id ...)
(lambda (val)
(chk val)
inner-lambda)))])
(make-contracted-function inner-lambda ctc))))])
(values (syntax (build--> '->*
(list doms ...)
rst
@ -353,10 +362,10 @@
(syntax (lambda args body))))])
(with-syntax ([outer-lambda
(syntax
(lambda (chk dom-x ... rst-x ignored dom-kwd-ctc-id ...)
(lambda (chk ctc dom-x ... rst-x ignored dom-kwd-ctc-id ...)
(lambda (val)
(chk val)
inner-lambda)))])
(make-contracted-function inner-lambda ctc))))])
(values (syntax (build--> '->*
(list doms ...)
rst