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:
parent
50e9aec0ab
commit
5cef41e08e
|
@ -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)])))
|
||||
|
|
|
@ -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))
|
||||
|
|
Loading…
Reference in New Issue
Block a user