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

misc minor improvments to unconstrained-domain->

Browse Source 
- add an optimization based on procedure-result-arity
 - make it generate less code
 - fix a few bugs
This commit is contained in:
Robby Findler 2016-08-29 11:19:18 -05:00
parent 56c97474b0
commit f878afb82b
2 changed files with 140 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
pkgs/racket-test/tests/racket/contract/unconstrained-domain.rkt
View File

@ -45,4 +45,27 @@
(test/pos-blame (test/pos-blame
'unconstrained-domain->7 'unconstrained-domain->7
'((contract (unconstrained-domain-> number?) (λ (#:x x) x) 'pos 'neg) #:x #f))) '((contract (unconstrained-domain-> number?) (λ (#:x x) x) 'pos 'neg) #:x #f))
(test/spec-passed/result
'unconstrained-domain->8
'(let ([f (λ (x) 0)])
(eq? (contract (unconstrained-domain-> any/c)
f
'pos
'neg)
f))
#t)
(test/pos-blame
'unconstrained-domain->9
'((contract (unconstrained-domain-> number? number?) (λ () (values #f 0)) 'pos 'neg)))
(test/pos-blame
'unconstrained-domain->10
'((contract (unconstrained-domain-> number? number?) (λ () (values 0 #f)) 'pos 'neg)))
(test/pos-blame
'unconstrained-domain->11
'((contract (unconstrained-domain-> number? number?) (λ () 1) 'pos 'neg)))
)

180
racket/collects/racket/contract/private/unconstrained-domain-arrow.rkt
View File

@ -4,58 +4,126 @@
"arrow-common.rkt" "arrow-common.rkt"
"blame.rkt" "blame.rkt"
"guts.rkt" "guts.rkt"
"prop.rkt") "prop.rkt"
"misc.rkt")
(provide unconstrained-domain->) (provide (rename-out [_unconstrained-domain-> unconstrained-domain->]))
(define-syntax (unconstrained-domain-> stx) (define-syntax (_unconstrained-domain-> stx)
(syntax-case stx () (syntax-case stx ()
[(_ rngs ...) [(_ rngs ...)
(with-syntax ([(rngs-x ...) (generate-temporaries #'(rngs ...))] (with-syntax ([(res-x ...) (generate-temporaries #'(rngs ...))]
[(proj-x ...) (generate-temporaries #'(rngs ...))] [(p-app-x ...) (generate-temporaries #'(rngs ...))])
[(p-app-x ...) (generate-temporaries #'(rngs ...))] #`(build-unconstrained-domain->
[(res-x ...) (generate-temporaries #'(rngs ...))]) (list rngs ...)
#`(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...) (λ (val blame+neg-party rngs-list blame-party-info neg-party p-app-x ...)
(let ([rngs-list (list rngs-x ...)] (define res-checker
[proj-x (get/build-late-neg-projection rngs-x)] ...) (case-lambda
(define (projection wrapper get-ctc) [(res-x ...) (values/drop (p-app-x res-x neg-party) ...)]
(λ (orig-blame) [results
(define blame-party-info (get-blame-party-info orig-blame)) (bad-number-of-results (car blame+neg-party)
(define ctc (get-ctc)) val
(let ([rng-blame (blame-add-range-context orig-blame)]) #,(length (syntax->list #'(rngs ...)))
(let* ([p-app-x (proj-x rng-blame)] ...) results
(λ (val neg-party) #:missing-party neg-party)]))
(check-is-a-procedure orig-blame neg-party val) (make-keyword-procedure
(define (res-checker res-x ...) (values/drop (p-app-x res-x neg-party) ...)) (λ (kwds kwd-vals . args)
(define blame+neg-party (cons orig-blame neg-party)) (with-contract-continuation-mark
(wrapper blame+neg-party
val #,(check-tail-contract
(make-keyword-procedure #'rngs-list
(λ (kwds kwd-vals . args) #'blame-party-info
(with-contract-continuation-mark #'neg-party
blame+neg-party (list #'res-checker)
#,(check-tail-contract (λ (s) #`(apply values #,@s kwd-vals args))
#'rngs-list #'blame+neg-party)))
#'blame-party-info (λ args
#'neg-party (with-contract-continuation-mark
(list #'res-checker) blame+neg-party
(λ (s) #`(apply values #,@s kwd-vals args)) #,(check-tail-contract
#'blame+neg-party))) #'rngs-list
(λ args #'blame-party-info
(with-contract-continuation-mark #'neg-party
blame+neg-party (list #'res-checker)
#,(check-tail-contract (λ (s) #`(apply values #,@s args))
#'rngs-list #'blame+neg-party)))))))]))
#'blame-party-info
#'neg-party (define (build-unconstrained-domain-> range-maybe-contracts wrapper-proc)
(list #'res-checker) (define range-contracts (coerce-contracts 'unconstrained-domain-> range-maybe-contracts))
(λ (s) #`(apply values #,@s args)) (define chaperone? (andmap chaperone-contract? range-contracts))
#'blame+neg-party)))) (cond
impersonator-prop:contracted ctc [chaperone?
impersonator-prop:application-mark (make-chaperone-unconstrained-domain-> range-contracts wrapper-proc)]
(cons tail-contract-key (list neg-party blame-party-info rngs-x ...)))))))) [else
(make-unconstrained-domain-> (list rngs-x ...) (make-impersonator-unconstrained-domain-> range-contracts wrapper-proc)]))
projection))))]))
(define (unconstrained-domain->-projection ctc)
(define range-contracts (unconstrained-domain->-ranges ctc))
(define make-wrapper-proc (unconstrained-domain->-make-wrapper-proc ctc))
(define late-neg-projections (map get/build-late-neg-projection range-contracts))
(define can-check-procedure-result-arity? (andmap any/c? range-contracts))
(define desired-procedure-result-arity (length range-contracts))
(define chaperone-or-impersonate-procedure (if (chaperone-unconstrained-domain->? ctc)
chaperone-procedure
impersonate-procedure))
(λ (orig-blame)
(define blame-party-info (get-blame-party-info orig-blame))
(define range-blame (blame-add-range-context orig-blame))
(define projs (for/list ([late-neg-projection (in-list late-neg-projections)])
(late-neg-projection range-blame)))
(λ (val neg-party)
(check-is-a-procedure orig-blame neg-party val)
(define blame+neg-party (cons orig-blame neg-party))
(if (and can-check-procedure-result-arity?
(equal? desired-procedure-result-arity
(procedure-result-arity val)))
val
(chaperone-or-impersonate-procedure
val
(apply make-wrapper-proc
val
blame+neg-party
range-contracts
blame-party-info
neg-party
projs)
impersonator-prop:contracted ctc
impersonator-prop:application-mark
(cons tail-contract-key (list* neg-party blame-party-info range-contracts)))))))
(define (unconstrained-domain->-name ud)
(apply build-compound-type-name 'unconstrained-domain->
(map contract-name (unconstrained-domain->-ranges ud))))
(define (unconstrained-domain->-first-order ud)
(λ (val)
(procedure? val)))
(define (unconstrained-domain->-stronger this that)
(and (unconstrained-domain->? that)
(pairwise-stronger-contracts? (unconstrained-domain->-ranges this)
(unconstrained-domain->-ranges that))))
(define-struct unconstrained-domain-> (ranges make-wrapper-proc)
#:property prop:custom-write custom-write-property-proc)
(define-struct (chaperone-unconstrained-domain-> unconstrained-domain->) ()
#:property
prop:chaperone-contract
(build-chaperone-contract-property
#:name unconstrained-domain->-name
#:first-order unconstrained-domain->-first-order
#:late-neg-projection unconstrained-domain->-projection
#:stronger unconstrained-domain->-stronger))
(define-struct (impersonator-unconstrained-domain-> unconstrained-domain->) ()
#:property
prop:chaperone-contract
(build-chaperone-contract-property
#:name unconstrained-domain->-name
#:first-order unconstrained-domain->-first-order
#:late-neg-projection unconstrained-domain->-projection
#:stronger unconstrained-domain->-stronger))
(define (check-is-a-procedure orig-blame neg-party val) (define (check-is-a-procedure orig-blame neg-party val)
(unless (procedure? val) (unless (procedure? val)
@ -63,19 +131,3 @@
val val
'(expected: "a procedure" given: "~v") '(expected: "a procedure" given: "~v")
val))) val)))
(define (make-unconstrained-domain-> ctcs late-neg-projection)
(define name
(apply build-compound-type-name 'unconstrained-domain->
(map contract-name ctcs)))
(define ctc
(if (andmap chaperone-contract? ctcs)
(make-chaperone-contract
#:name name
#:late-neg-projection (late-neg-projection chaperone-procedure (λ () ctc))
#:first-order procedure?)
(make-contract
#:name name
#:late-neg-projection (late-neg-projection impersonate-procedure (λ () ctc))
#:first-order procedure?)))
ctc)