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

change or/c so that it takes the first ho projection

Browse Source 
whose first-order predicate accepts a value, instead
of requiring that there be exactly one
This commit is contained in:
Robby Findler 2015-09-22 09:05:34 -05:00
parent 45b635f707
commit 5a33856802
3 changed files with 36 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
pkgs/racket-doc/scribblings/reference/contracts.scrbl
View File

@ -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?]{

22
pkgs/racket-test/tests/racket/contract/or-and.rkt
View File

@ -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))

64
racket/collects/racket/contract/private/orc.rkt
View File

@ -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))]