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

fixed error messages to say struct/c when appropriate

Browse Source
This commit is contained in:
Robby Findler 2017-01-04 16:49:38 -06:00
parent 67da8dbaf0
commit 057ab0c5ff
2 changed files with 23 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1217,6 +1217,15 @@
(λ (x) (λ (x)
(and (exn:fail? x) (and (exn:fail? x)
(regexp-match #rx"chaperone-contract[?]" (exn-message x))))) (regexp-match #rx"chaperone-contract[?]" (exn-message x)))))
(contract-error-test
'struct/c-non-chaperone-runtime-error
'(let ()
(struct s (x))
(struct/c s (new-∀/c 'α)))
(λ (x)
(and (exn:fail? x)
(regexp-match #rx"^struct/c" (exn-message x)))))
(contract-error-test (contract-error-test
'struct/dc-not-a-field 'struct/dc-not-a-field

25
racket/collects/racket/contract/private/struct-dc.rkt
View File

@ -225,6 +225,7 @@
(define (struct/dc-late-neg-proj ctc) (define (struct/dc-late-neg-proj ctc)
(define pred? (base-struct/dc-pred ctc)) (define pred? (base-struct/dc-pred ctc))
(define struct/c? (base-struct/dc-struct/c? ctc))
(λ (blame) (λ (blame)
(define orig-blames (define orig-blames
(for/list ([subcontract (in-list (base-struct/dc-subcontracts ctc))]) (for/list ([subcontract (in-list (base-struct/dc-subcontracts ctc))])
@ -343,7 +344,7 @@
(coerce-contract (coerce-contract
'struct/dc 'struct/dc
(apply (dep-dep-proc subcontract) dep-args)))) (apply (dep-dep-proc subcontract) dep-args))))
(when dep-ctc (check-flat/chaperone dep-ctc subcontract)) (when dep-ctc (check-flat/chaperone dep-ctc subcontract struct/c?))
(define dep-ctc-blame-proj (and dep-ctc (get/build-late-neg-projection dep-ctc))) (define dep-ctc-blame-proj (and dep-ctc (get/build-late-neg-projection dep-ctc)))
(define-values (new-chaperone-args new-impersonate-args) (define-values (new-chaperone-args new-impersonate-args)
(cond (cond
@ -453,7 +454,8 @@
blame+neg-party blame+neg-party
(build-dep-on-state-proj (build-dep-on-state-proj
(base-struct/dc-subcontracts ctc) subcontract strct (base-struct/dc-subcontracts ctc) subcontract strct
orig-indy-projs orig-indy-blames blame neg-party val))) orig-indy-projs orig-indy-blames blame neg-party val
struct/c?)))
chaperone-args) chaperone-args)
impersonate-args)] impersonate-args)]
[(dep-on-state-mutable? subcontract) [(dep-on-state-mutable? subcontract)
@ -463,13 +465,14 @@
blame+neg-party blame+neg-party
(build-dep-on-state-proj (base-struct/dc-subcontracts ctc) subcontract strct (build-dep-on-state-proj (base-struct/dc-subcontracts ctc) subcontract strct
orig-indy-projs orig-indy-blames blame neg-party orig-indy-projs orig-indy-blames blame neg-party
val))) val struct/c?)))
(define (set-chap-proc strct val) (define (set-chap-proc strct val)
(with-contract-continuation-mark (with-contract-continuation-mark
blame+neg-party blame+neg-party
(build-dep-on-state-proj (build-dep-on-state-proj
(base-struct/dc-subcontracts ctc) subcontract strct (base-struct/dc-subcontracts ctc) subcontract strct
orig-mut-indy-projs orig-mut-indy-blames mut-blame neg-party val))) orig-mut-indy-projs orig-mut-indy-blames mut-blame neg-party val
struct/c?)))
(if (eq? (dep-type subcontract) '#:impersonator) (if (eq? (dep-type subcontract) '#:impersonator)
(values chaperone-args (values chaperone-args
(list* sel (list* sel
@ -577,7 +580,7 @@
(cons (car l) (remove-ith (cdr l) (- i 1))))])) (cons (car l) (remove-ith (cdr l) (- i 1))))]))
(define (build-dep-on-state-proj orig-subcontracts this-subcontract strct projs (define (build-dep-on-state-proj orig-subcontracts this-subcontract strct projs
blames blame neg-party val) blames blame neg-party val struct/c?)
(let loop ([subcontracts orig-subcontracts] (let loop ([subcontracts orig-subcontracts]
[blames blames] [blames blames]
[projs projs] [projs projs]
@ -593,7 +596,7 @@
[(eq? subcontract this-subcontract) [(eq? subcontract this-subcontract)
(define the-ctc (define the-ctc
(coerce-contract 'struct/dc (apply (dep-dep-proc this-subcontract) dep-args))) (coerce-contract 'struct/dc (apply (dep-dep-proc this-subcontract) dep-args)))
(check-flat/chaperone the-ctc subcontract) (check-flat/chaperone the-ctc subcontract struct/c?)
(((get/build-late-neg-projection the-ctc) blame) val neg-party)] (((get/build-late-neg-projection the-ctc) blame) val neg-party)]
[else [else
(define indy-blame (car blames)) (define indy-blame (car blames))
@ -606,7 +609,7 @@
(define dep-ctc-blame-proj (and dep-ctc (get/build-late-neg-projection dep-ctc))) (define dep-ctc-blame-proj (and dep-ctc (get/build-late-neg-projection dep-ctc)))
(when (dep? subcontract) (when (dep? subcontract)
(check-flat/chaperone dep-ctc subcontract)) (check-flat/chaperone dep-ctc subcontract struct/c?))
(define new-dep-args (define new-dep-args
(if (and (subcontract? subcontract) (subcontract-depended-on? subcontract)) (if (and (subcontract? subcontract) (subcontract-depended-on? subcontract))
@ -622,18 +625,18 @@
(cdr projs) (cdr projs)
new-dep-args)])]))) new-dep-args)])])))
(define (check-flat/chaperone dep-ctc subcontract) (define (check-flat/chaperone dep-ctc subcontract struct/c?)
(case (dep-type subcontract) (case (dep-type subcontract)
[(#:flat) [(#:flat)
(unless (flat-contract? dep-ctc) (unless (flat-contract? dep-ctc)
(raise-argument-error (raise-argument-error
'struct/dc (if struct/c? 'struct/c 'struct/dc)
(format "a flat-contract? for field ~a" (subcontract-field-name subcontract)) (format "a flat-contract? for field ~a" (subcontract-field-name subcontract))
dep-ctc))] dep-ctc))]
[(#:chaperone) [(#:chaperone)
(unless (chaperone-contract? dep-ctc) (unless (chaperone-contract? dep-ctc)
(raise-argument-error (raise-argument-error
'struct/dc (if struct/c? 'struct/c 'struct/dc)
(format "a chaperone-contract? for field ~a" (subcontract-field-name subcontract)) (format "a chaperone-contract? for field ~a" (subcontract-field-name subcontract))
dep-ctc))])) dep-ctc))]))
@ -726,7 +729,7 @@
(not (mutable? subcontract))) (not (mutable? subcontract)))
(unless (chaperone-contract? (indep-ctc subcontract)) (unless (chaperone-contract? (indep-ctc subcontract))
(raise-argument-error (raise-argument-error
'struct/dc (if struct/c? 'struct/c 'struct/dc)
(format "a chaperone-contract? for field ~a" (subcontract-field-name subcontract)) (format "a chaperone-contract? for field ~a" (subcontract-field-name subcontract))
(indep-ctc subcontract))))) (indep-ctc subcontract)))))
(define (flat-subcontract? subcontract) (define (flat-subcontract? subcontract)