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

improve error messages from contract system

Browse Source 
closes PR 15057
This commit is contained in:
Robby Findler 2015-05-09 11:53:56 -05:00
parent bd5723c51c
commit 7fb67ad644
6 changed files with 28 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
pkgs/racket-test/tests/racket/contract/class.rkt
View File

@ -2529,9 +2529,14 @@
(regexp-match? #rx"expected: boolean[?]" (exn-message exn))
(regexp-match? #rx"given: 1" (exn-message exn))))]
[promised-produced?
(λ (exn) (and (regexp-match? #rx"callback: broke its contract" (exn-message exn))
(λ (exn)
(define ans
(and (regexp-match? #rx"callback: broke its own contract" (exn-message exn))
(regexp-match? #rx"promised: boolean[?]" (exn-message exn))
(regexp-match? #rx"produced: 1" (exn-message exn))))])
(regexp-match? #rx"produced: 1" (exn-message exn))))
(unless ans
(printf "~a\n" (exn-message exn)))
ans)])
(contract-error-test
'blame-important1
'(send (new (contract (class/c [callback (->m boolean? void)])

4
pkgs/racket-test/tests/racket/contract/context.rkt
View File

@ -94,13 +94,13 @@
'neg))
1))
(context-test '("a disjunct of")
(context-test '("a part of the or/c of")
'(contract (or/c 1 (-> number? number?))
3
'pos
'neg))
(context-test '("the range of" "a disjunct of")
(context-test '("the range of" "a part of the or/c of")
'((contract (or/c 1 (-> number? number?) (-> number? boolean? number?))
(λ (x) #f)
'pos

2
pkgs/racket-test/tests/racket/contract/contract-out.rkt
View File

@ -1007,7 +1007,7 @@
(eval '(require 'pce1-bug)))
(λ (x)
(and (exn:fail:contract:blame? x)
(regexp-match #rx"the-defined-variable1: broke its contract" (exn-message x)))))
(regexp-match #rx"the-defined-variable1: broke its own contract" (exn-message x)))))
(contract-error-test
'contract-error-test9

16
racket/collects/racket/contract/private/arrow.rkt
View File

@ -396,9 +396,13 @@
[else
(define arity-string
(if max-arity
(if (= min-method-arity max-method-arity)
(format "~a non-keyword argument~a" min-method-arity (if (= min-method-arity 1) "" "s"))
(format "~a to ~a non-keyword arguments" min-method-arity max-method-arity))
(cond
[(= min-method-arity max-method-arity)
(format "~a non-keyword argument~a" min-method-arity (if (= min-method-arity 1) "" "s"))]
[(= (+ min-method-arity 1) max-method-arity)
(format "~a or ~a non-keyword arguments" min-method-arity max-method-arity)]
[else
(format "~a to ~a non-keyword arguments" min-method-arity max-method-arity)])
(format "at least ~a non-keyword argument~a" min-method-arity (if (= min-method-arity 1) "" "s"))))
(define-values (vr va) (procedure-keywords val))
(define all-kwds (append req-kwd opt-kwd))
@ -432,7 +436,7 @@
(define args-len (length args))
(unless (valid-number-of-args? args)
(raise-blame-error (blame-swap blame) val
'("received ~a argument~a" expected: "~a")
'(received: "~a argument~a" expected: "~a")
args-len (if (= args-len 1) "" "s") arity-string))
;; these two for loops are doing O(n^2) work that could be linear
@ -445,7 +449,7 @@
(for ([k (in-list kwds)])
(unless (memq k all-kwds)
(raise-blame-error (blame-swap blame) val
"received unexpected keyword argument ~a"
'(received: "unexpected keyword argument ~a")
k)))
(keyword-apply kwd-lambda kwds kwd-args args))))))
(define basic-checker-name
@ -457,7 +461,7 @@
(unless (valid-number-of-args? args)
(define args-len (length args))
(raise-blame-error (blame-swap blame) val
'("received ~a argument~a" expected: "~a")
'(received: "~a argument~a" expected: "~a")
args-len (if (= args-len 1) "" "s") arity-string))
(apply basic-lambda args))))
(λ args

6
racket/collects/racket/contract/private/blame.rkt
View File

@ -226,6 +226,10 @@
[(eq? 'expected fst) (if (blame/important-original? blame)
"promised"
"expected")]
[(eq? 'received: fst) (add-indent
(if (blame/important-original? blame)
"supplied:"
"received:"))]
[else fst]))
(define new-so-far
(if (or last-ended-in-whitespace?
@ -269,7 +273,7 @@
(define self-or-not
(if (blame/important-original? blme)
"broke its contract"
"broke its own contract"
"contract violation"))
(define start-of-message

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

@ -79,7 +79,7 @@
(p-app val)))))
(define (blame-add-or-context blame)
(blame-add-context blame "a disjunct of"))
(blame-add-context blame "a part of the or/c of"))
(define (single-or/c-first-order ctc)
(let ([pred (single-or/c-pred ctc)]
@ -231,7 +231,7 @@
[first-order-checks (map (λ (x) (contract-first-order x)) ho-contracts)]
[predicates (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))])
(λ (blame)
(define disj-blame (blame-add-context blame "a disjunct of"))
(define disj-blame (blame-add-context blame "a part of the or/c of"))
(define partial-contracts
(for/list ([c-proc (in-list c-procs)])
(c-proc disj-blame)))