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

adjust ->i to fall back to the slow path to signal the error

Browse Source 
because the existing shortcut didn't gave the right message all the
time.

Closes #3286
This commit is contained in:
Robby Findler 2020-07-04 17:40:49 -05:00
parent ddacbfa174
commit ac4ae9ebba
2 changed files with 35 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
pkgs/racket-test/tests/racket/contract/arrow-i.rkt
View File

@ -2,7 +2,8 @@
(require "test-util.rkt") (require "test-util.rkt")
(parameterize ([current-contract-namespace (parameterize ([current-contract-namespace
(make-basic-contract-namespace 'racket/contract/parametric)]) (make-basic-contract-namespace 'racket/contract/parametric
'racket/contract/combinator)])
(define exn:fail:contract:blame? (contract-eval 'exn:fail:contract:blame?)) (define exn:fail:contract:blame? (contract-eval 'exn:fail:contract:blame?))
(test/no-error '(->i ([x integer?]) ([y integer?]) any)) (test/no-error '(->i ([x integer?]) ([y integer?]) any))
@ -1821,7 +1822,7 @@
#t) #t)
(test/spec-passed/result (test/spec-passed/result
'shortcut-error-message 'shortcut-error-message-1
'(with-handlers ([exn:fail? '(with-handlers ([exn:fail?
(λ (x) (define m (λ (x) (define m
(regexp-match #rx"expected: ([^\n]*)\n" (regexp-match #rx"expected: ([^\n]*)\n"
@ -1834,7 +1835,29 @@
(λ (y) 1) (λ (y) 1)
'pos 'neg) 'pos 'neg)
1)) 1))
"(and/c number? (>/c 1))") "a number strictly greater than 1")
(contract-error-test
'shortcut-error-message-2
'(let ()
(define ctc
(make-flat-contract
#:first-order (λ (x) #f)
#:late-neg-projection
(λ (b)
(λ (x neg-party)
(raise-blame-error
b x #:missing-party neg-party
"an informative error message")))))
((contract (->i ([x any/c])
[_ (x) ctc])
(λ (x) 42)
'pos 'neg)
10))
(λ (x)
(and (exn:fail:contract:blame? x)
(regexp-match? #rx"an informative error message"
(exn-message x)))))
(test/spec-passed/result (test/spec-passed/result
'two-underscores 'two-underscores
@ -1858,5 +1881,4 @@
55 66)) 55 66))
list) list)
'(1 2 3 4)) '(1 2 3 4))
) )

9
racket/collects/racket/contract/private/arr-i.rkt
View File

@ -1140,15 +1140,18 @@ evaluted left-to-right.)
(procedure-arity-includes? orig-ctc 1)) (procedure-arity-includes? orig-ctc 1))
(if (or indy-blame? (orig-ctc obj)) (if (or indy-blame? (orig-ctc obj))
obj obj
(raise-predicate-blame-error-failure blame obj neg-party ;; this will signal the violation
(contract-name orig-ctc)))] (undep-and-apply-the-contract orig-ctc obj blame neg-party chaperone?))]
[(and indy-blame? (flat-contract? orig-ctc)) [(and indy-blame? (flat-contract? orig-ctc))
obj] obj]
[else [else
(undep-and-apply-the-contract orig-ctc obj blame neg-party chaperone?)]))
(define (undep-and-apply-the-contract orig-ctc obj blame neg-party chaperone?)
(define ctc (if chaperone? (define ctc (if chaperone?
(coerce-chaperone-contract '->i orig-ctc) (coerce-chaperone-contract '->i orig-ctc)
(coerce-contract '->i orig-ctc))) (coerce-contract '->i orig-ctc)))
(((get/build-late-neg-projection ctc) blame) obj neg-party)])) (((get/build-late-neg-projection ctc) blame) obj neg-party))
(define (un-dep/chaperone orig-ctc obj blame neg-party indy-blame?) (define (un-dep/chaperone orig-ctc obj blame neg-party indy-blame?)
(un-dep/maybe-chaperone orig-ctc obj blame neg-party #t indy-blame?)) (un-dep/maybe-chaperone orig-ctc obj blame neg-party #t indy-blame?))