From 5a33856802f1f82260dc07ab1c3b9df3175867a9 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 22 Sep 2015 09:05:34 -0500 Subject: [PATCH] change or/c so that it takes the first ho projection whose first-order predicate accepts a value, instead of requiring that there be exactly one --- .../scribblings/reference/contracts.scrbl | 18 ++++-- .../tests/racket/contract/or-and.rkt | 22 ++++--- .../collects/racket/contract/private/orc.rkt | 64 ++++--------------- 3 files changed, 36 insertions(+), 68 deletions(-) diff --git a/pkgs/racket-doc/scribblings/reference/contracts.scrbl b/pkgs/racket-doc/scribblings/reference/contracts.scrbl index 298383b243..e75547f03f 100644 --- a/pkgs/racket-doc/scribblings/reference/contracts.scrbl +++ b/pkgs/racket-doc/scribblings/reference/contracts.scrbl @@ -182,21 +182,25 @@ If there are multiple higher-order contracts, @racket[or/c] uses them. More precisely, when an @racket[or/c] is checked, it first checks all of the @tech{flat contracts}. If none of them pass, it calls @racket[contract-first-order-passes?] with each of the -higher-order contracts. If only one returns true, @racket[or/c] uses -that contract. If none of them return true, it signals a contract -violation. If more than one returns true, it also signals a contract -violation. +higher-order contracts, taking the first one that returns +true as the contract for the value. + For example, this contract @racketblock[ (or/c (-> number? number?) (-> string? string? string?)) ] -does not accept a function like this one: @racket[(lambda args ...)] -since it cannot tell which of the two arrow contracts should be used -with the function. +accepts a function like this one: @racket[(lambda args ...)], +using the @racket[(-> number? number?)] contract on it, ignoring +the @racket[(-> string? string? string?)] contract since it came +second. If all of its arguments are @racket[list-contract?]s, then @racket[or/c] returns a @racket[list-contract?]. + +@history[#:changed "6.2.900.17" @list{Adjusted @racket[or/c] so that it + takes the first higher-order contract instead of insisting that + there be exactly one higher-order contract for a given value.}] } @defproc[(and/c [contract contract?] ...) contract?]{ diff --git a/pkgs/racket-test/tests/racket/contract/or-and.rkt b/pkgs/racket-test/tests/racket/contract/or-and.rkt index 32cecad7ad..7b41b4cc65 100644 --- a/pkgs/racket-test/tests/racket/contract/or-and.rkt +++ b/pkgs/racket-test/tests/racket/contract/or-and.rkt @@ -86,14 +86,6 @@ 1) 1) - (contract-error-test - 'contract-error-test4 - #'(contract (or/c (-> integer? integer?) (-> boolean? boolean?)) - (λ (x) x) - 'pos - 'neg) - exn:fail?) - (test/spec-passed/result 'or/c-ordering '(let ([x '()]) @@ -231,11 +223,21 @@ 'pos 'neg) (lambda (x y z) 1))) - (test/neg-blame + (test/spec-passed/result 'ho-or/c-val-first2 + '((contract (or/c (-> integer? integer?) (-> boolean? boolean?)) + (λ (x) x) + 'pos + 'neg) + 1) + 1) + + (test/spec-passed/result + 'ho-or/c-val-first3 '((contract (-> (or/c (-> number? number?) (-> number? number?)) number?) (λ (x) 1) 'pos 'neg) - (lambda (x) 1)))) + (lambda (x) 1)) + 1)) diff --git a/racket/collects/racket/contract/private/orc.rkt b/racket/collects/racket/contract/private/orc.rkt index d1ee02c67f..de482e19d6 100644 --- a/racket/collects/racket/contract/private/orc.rkt +++ b/racket/collects/racket/contract/private/orc.rkt @@ -22,7 +22,7 @@ [flat-contracts '()] [args args]) (cond - [(null? args) (values ho-contracts (reverse flat-contracts))] + [(null? args) (values (reverse ho-contracts) (reverse flat-contracts))] [else (let ([arg (car args)]) (cond @@ -242,36 +242,18 @@ [else (let loop ([checks first-order-checks] [procs partial-contracts] - [contracts ho-contracts] - [candidate-proc #f] - [candidate-contract #f]) + [contracts ho-contracts]) (cond [(null? checks) - (if candidate-proc - (candidate-proc val) - (raise-blame-error blame val - '("none of the branches of the or/c matched" given: "~e") - val))] + (raise-blame-error blame val + '("none of the branches of the or/c matched" given: "~e") + val)] [((car checks) val) - (if candidate-proc - (raise-blame-error blame val - '("two of the clauses in the or/c might both match: ~s and ~s" - given: - "~e") - (contract-name candidate-contract) - (contract-name (car contracts)) - val) - (loop (cdr checks) - (cdr procs) - (cdr contracts) - (car procs) - (car contracts)))] + ((car procs) val)] [else (loop (cdr checks) (cdr procs) - (cdr contracts) - candidate-proc - candidate-contract)]))]))))) + (cdr contracts))]))]))))) (define (multi-or/c-late-neg-proj ctc) (define ho-contracts (multi-or/c-ho-ctcs ctc)) @@ -289,38 +271,18 @@ [else (let loop ([checks first-order-checks] [c-projs c-projs+blame] - [contracts ho-contracts] - [candidate-c-proj #f] - [candidate-contract #f]) + [contracts ho-contracts]) (cond [(null? checks) - (cond - [candidate-c-proj - (candidate-c-proj val neg-party)] - [else - (raise-blame-error blame val #:missing-party neg-party - '("none of the branches of the or/c matched" given: "~e") - val)])] + (raise-blame-error blame val #:missing-party neg-party + '("none of the branches of the or/c matched" given: "~e") + val)] [((car checks) val) - (if candidate-c-proj - (raise-blame-error blame val #:missing-party neg-party - '("two of the clauses in the or/c might both match: ~s and ~s" - given: - "~e") - (contract-name candidate-contract) - (contract-name (car contracts)) - val) - (loop (cdr checks) - (cdr c-projs) - (cdr contracts) - (car c-projs) - (car contracts)))] + ((car c-projs) val neg-party)] [else (loop (cdr checks) (cdr c-projs) - (cdr contracts) - candidate-c-proj - candidate-contract)]))])))) + (cdr contracts))]))])))) (define (multi-or/c-first-order ctc) (let ([flats (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))]