misc minor improvments to unconstrained-domain->
- add an optimization based on procedure-result-arity - make it generate less code - fix a few bugs
This commit is contained in:
Robby Findler
parent
56c97474b0
commit
f878afb82b
|
|
@ -45,4 +45,27 @@
|
|||
|
||||
(test/pos-blame
|
||||
'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)))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -4,32 +4,28 @@
|
|||
"arrow-common.rkt"
|
||||
"blame.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 ()
|
||||
[(_ rngs ...)
|
||||
(with-syntax ([(rngs-x ...) (generate-temporaries #'(rngs ...))]
|
||||
[(proj-x ...) (generate-temporaries #'(rngs ...))]
|
||||
[(p-app-x ...) (generate-temporaries #'(rngs ...))]
|
||||
[(res-x ...) (generate-temporaries #'(rngs ...))])
|
||||
#`(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
|
||||
(let ([rngs-list (list rngs-x ...)]
|
||||
[proj-x (get/build-late-neg-projection rngs-x)] ...)
|
||||
(define (projection wrapper get-ctc)
|
||||
(λ (orig-blame)
|
||||
(define blame-party-info (get-blame-party-info orig-blame))
|
||||
(define ctc (get-ctc))
|
||||
(let ([rng-blame (blame-add-range-context orig-blame)])
|
||||
(let* ([p-app-x (proj-x rng-blame)] ...)
|
||||
(λ (val neg-party)
|
||||
(check-is-a-procedure orig-blame neg-party val)
|
||||
(define (res-checker res-x ...) (values/drop (p-app-x res-x neg-party) ...))
|
||||
(define blame+neg-party (cons orig-blame neg-party))
|
||||
(wrapper
|
||||
(with-syntax ([(res-x ...) (generate-temporaries #'(rngs ...))]
|
||||
[(p-app-x ...) (generate-temporaries #'(rngs ...))])
|
||||
#`(build-unconstrained-domain->
|
||||
(list rngs ...)
|
||||
(λ (val blame+neg-party rngs-list blame-party-info neg-party p-app-x ...)
|
||||
(define res-checker
|
||||
(case-lambda
|
||||
[(res-x ...) (values/drop (p-app-x res-x neg-party) ...)]
|
||||
[results
|
||||
(bad-number-of-results (car blame+neg-party)
|
||||
val
|
||||
#,(length (syntax->list #'(rngs ...)))
|
||||
results
|
||||
#:missing-party neg-party)]))
|
||||
(make-keyword-procedure
|
||||
(λ (kwds kwd-vals . args)
|
||||
(with-contract-continuation-mark
|
||||
|
|
@ -50,12 +46,84 @@
|
|||
#'neg-party
|
||||
(list #'res-checker)
|
||||
(λ (s) #`(apply values #,@s args))
|
||||
#'blame+neg-party))))
|
||||
#'blame+neg-party)))))))]))
|
||||
|
||||
(define (build-unconstrained-domain-> range-maybe-contracts wrapper-proc)
|
||||
(define range-contracts (coerce-contracts 'unconstrained-domain-> range-maybe-contracts))
|
||||
(define chaperone? (andmap chaperone-contract? range-contracts))
|
||||
(cond
|
||||
[chaperone?
|
||||
(make-chaperone-unconstrained-domain-> range-contracts wrapper-proc)]
|
||||
[else
|
||||
(make-impersonator-unconstrained-domain-> range-contracts wrapper-proc)]))
|
||||
|
||||
(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 rngs-x ...))))))))
|
||||
(make-unconstrained-domain-> (list rngs-x ...)
|
||||
projection))))]))
|
||||
(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)
|
||||
(unless (procedure? val)
|
||||
|
|
@ -63,19 +131,3 @@
|
|||
val
|
||||
'(expected: "a procedure" given: "~v")
|
||||
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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user