diff --git a/pkgs/racket-test/tests/racket/contract/unconstrained-domain.rkt b/pkgs/racket-test/tests/racket/contract/unconstrained-domain.rkt index 75139c2209..3506540185 100644 --- a/pkgs/racket-test/tests/racket/contract/unconstrained-domain.rkt +++ b/pkgs/racket-test/tests/racket/contract/unconstrained-domain.rkt @@ -45,4 +45,27 @@ (test/pos-blame 'unconstrained-domain->7 - '((contract (unconstrained-domain-> number?) (λ (#:x x) x) 'pos 'neg) #:x #f))) \ No newline at end of file + '((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))) + ) diff --git a/racket/collects/racket/contract/private/unconstrained-domain-arrow.rkt b/racket/collects/racket/contract/private/unconstrained-domain-arrow.rkt index 4055af7e85..886cc37e9e 100644 --- a/racket/collects/racket/contract/private/unconstrained-domain-arrow.rkt +++ b/racket/collects/racket/contract/private/unconstrained-domain-arrow.rkt @@ -4,58 +4,126 @@ "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 - val - (make-keyword-procedure - (λ (kwds kwd-vals . args) - (with-contract-continuation-mark - blame+neg-party - #,(check-tail-contract - #'rngs-list - #'blame-party-info - #'neg-party - (list #'res-checker) - (λ (s) #`(apply values #,@s kwd-vals args)) - #'blame+neg-party))) - (λ args - (with-contract-continuation-mark - blame+neg-party - #,(check-tail-contract - #'rngs-list - #'blame-party-info - #'neg-party - (list #'res-checker) - (λ (s) #`(apply values #,@s args)) - #'blame+neg-party)))) - 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))))])) + (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 + blame+neg-party + #,(check-tail-contract + #'rngs-list + #'blame-party-info + #'neg-party + (list #'res-checker) + (λ (s) #`(apply values #,@s kwd-vals args)) + #'blame+neg-party))) + (λ args + (with-contract-continuation-mark + blame+neg-party + #,(check-tail-contract + #'rngs-list + #'blame-party-info + #'neg-party + (list #'res-checker) + (λ (s) #`(apply values #,@s args)) + #'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 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)