adjust and/c so that it mentions the particular predicate (flat contract) that failed in the case that all its arguments are flat contracts

This commit is contained in:
Robby Findler 2011-02-10 11:31:28 -06:00
parent 50e9aec0ab
commit 5cef41e08e
2 changed files with 39 additions and 3 deletions

View File

@ -322,6 +322,24 @@
([p (in-list (cdr projs))])
(λ (v) (p (proj v))))))))
(define (first-order-and-proj ctc)
(λ (blame)
(λ (val)
(let loop ([predicates (first-order-and/c-predicates ctc)]
[ctcs (base-and/c-ctcs ctc)])
(cond
[(null? predicates) val]
[else
(if ((car predicates) val)
(loop (cdr predicates) (cdr ctcs))
(raise-blame-error
blame
val
"expected <~s>, given ~a, which isn't ~s"
(contract-name ctc)
val
(contract-name (car ctcs))))])))))
(define (and-stronger? this that)
(and (base-and/c? that)
(let ([this-ctcs (base-and/c-ctcs this)]
@ -332,6 +350,13 @@
that-ctcs)))))
(define-struct base-and/c (ctcs))
(define-struct (first-order-and/c base-and/c) (predicates)
#:property prop:flat-contract
(build-flat-contract-property
#:projection first-order-and-proj
#:name and-name
#:first-order and-first-order
#:stronger and-stronger?))
(define-struct (chaperone-and/c base-and/c) ()
#:property prop:chaperone-contract
(build-chaperone-contract-property
@ -347,15 +372,14 @@
#:first-order and-first-order
#:stronger and-stronger?))
(define/subexpression-pos-prop (and/c . raw-fs)
(let ([contracts (coerce-contracts 'and/c raw-fs)])
(cond
[(null? contracts) any/c]
[(andmap flat-contract? contracts)
(let ([preds (map flat-contract-predicate contracts)])
(flat-named-contract
(apply build-compound-type-name 'and/c contracts)
(λ (x) (for/and ([pred (in-list preds)]) (pred x)))))]
(make-first-order-and/c contracts preds))]
[(andmap chaperone-contract? contracts)
(make-chaperone-and/c contracts)]
[else (make-impersonator-and/c contracts)])))

View File

@ -3533,6 +3533,18 @@
(reverse x))
'(3 1 2 4))
(test/spec-passed/result
'and/c-isnt
'(and (regexp-match #rx"isn't even?"
(with-handlers ((exn:fail? exn-message))
(contract (and/c integer? even? positive?)
-3
'pos
'neg)
"not the error!"))
#t)
#t)
(test/spec-passed
'contract-flat1
'(contract not #f 'pos 'neg))