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

Better error messages for class/object contracts

Browse Source
This commit is contained in:
Asumu Takikawa 2013-10-17 17:14:24 -04:00
parent 63c05d6cf5
commit 3264a7fd61
2 changed files with 24 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1748,4 +1748,24 @@
(class object% (class object%
(super-new) (super-new)
(define/public (callback f) (f 1)))) (define/public (callback f) (f 1))))
promised-produced?))) promised-produced?))
(let ([expected-obj
(λ (exn) (regexp-match? #rx"promised: an object" (exn-message exn)))]
[expected-class
(λ (exn) (regexp-match? #rx"promised: a class" (exn-message exn)))])
(contract-error-test
'not-an-object-1
'(contract (object/c) 3 'pos 'neg)
expected-obj)
(contract-error-test
'not-an-object-2
'(contract (instanceof/c (class/c)) 3 'pos 'neg)
expected-obj)
(contract-error-test
'not-a-class-1
'(contract (class/c) 3 'pos 'neg)
expected-class)))

6
racket/collects/racket/private/class-internal.rkt
View File

@ -2758,7 +2758,7 @@ An example
(define (class/c-check-first-order ctc cls fail) (define (class/c-check-first-order ctc cls fail)
(unless (class? cls) (unless (class? cls)
(fail "not a class")) (fail '(expected: "a class" given: "~v") cls))
(let ([method-ht (class-method-ht cls)] (let ([method-ht (class-method-ht cls)]
[beta-methods (class-beta-methods cls)] [beta-methods (class-beta-methods cls)]
[meth-flags (class-meth-flags cls)]) [meth-flags (class-meth-flags cls)])
@ -3516,7 +3516,7 @@ An example
(define (check-object-contract obj methods fields fail) (define (check-object-contract obj methods fields fail)
(unless (object? obj) (unless (object? obj)
(fail "not a object")) (fail '(expected: "an object" given: "~e") obj))
(let ([cls (object-ref obj)]) (let ([cls (object-ref obj)])
(let ([method-ht (class-method-ht cls)]) (let ([method-ht (class-method-ht cls)])
(for ([m methods]) (for ([m methods])
@ -3580,7 +3580,7 @@ An example
(let ([p (proj blame)]) (let ([p (proj blame)])
(λ (val) (λ (val)
(unless (object? val) (unless (object? val)
(raise-blame-error blame val "expected an object, got ~v" val)) (raise-blame-error blame val '(expected: "an object" given: "~e") val))
(let ([original-obj (if (has-original-object? val) (original-object val) val)] (let ([original-obj (if (has-original-object? val) (original-object val) val)]
[new-cls (p (object-ref val))]) [new-cls (p (object-ref val))])
(impersonate-struct val object-ref (λ (o c) new-cls) (impersonate-struct val object-ref (λ (o c) new-cls)