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

fixed more calls to error (that should be raise-argument-error) in the contract library

Browse Source
This commit is contained in:
Robby Findler 2013-03-24 08:08:18 -05:00
parent 64849bddd2
commit 57f857b45a
7 changed files with 83 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -573,7 +573,7 @@ v4 todo:
(λ args
; Make sure that the args match the contract
(begin (unless ((contract-struct-exercise ctc) args (/ fuel 2))
(error "Arg(s) ~a do(es) not match contract ~a\n" ctc))
(error '->-generate "Arg(s) ~a do(es) not match contract ~a\n" ctc))
; Stash the valid value
;(env-stash (generate-env) ctc args)
(apply values rngs-gens)))

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

@ -306,7 +306,9 @@ it around flattened out.
(do-selection struct (+ i 1))
(wrap-get struct (+ i 1)))]
[else
(error selector-name "expected: ~s, got ~e" 'name struct)]))
(raise-argument-error selector-name
'name
struct)]))
(define (lazy-contract-name ctc)
(do-contract-name 'struct/c

40
collects/racket/contract/private/hash.rkt
View File

@ -55,26 +55,26 @@
(vector this-one (list #'h/c) null))))]))
(define (hash/c dom rng #:immutable [immutable 'dont-care] #:flat? [flat? #f])
(unless (memq immutable '(#t #f dont-care))
(error 'hash/c "expected #:immutable argument to be either #t, #f, or 'dont-care, got ~s" immutable))
(let ([dom-ctc (if flat?
(coerce-flat-contract 'hash/c dom)
(coerce-contract 'hash/c dom))]
[rng-ctc (if flat?
(coerce-flat-contract 'hash/c rng)
(coerce-contract 'hash/c rng))])
(unless (chaperone-contract? dom-ctc)
(error 'hash/c "expected either a flat or chaperone contract for the domain, got ~s" (contract-name dom-ctc)))
(cond
[(or flat?
(and (eq? immutable #t)
(flat-contract? dom-ctc)
(flat-contract? rng-ctc)))
(make-flat-hash/c dom-ctc rng-ctc immutable)]
[(chaperone-contract? rng-ctc)
(make-chaperone-hash/c dom-ctc rng-ctc immutable)]
[else
(make-impersonator-hash/c dom-ctc rng-ctc immutable)])))
(unless (member immutable '(#t #f dont-care))
(raise-argument-error 'hash/c
"(or/c #t #f 'dont-care) for the #:immutable argument"
immutable))
(define dom-ctc (if flat?
(coerce-flat-contract 'hash/c dom)
(coerce-chaperone-contract 'hash/c dom)))
(define rng-ctc (if flat?
(coerce-flat-contract 'hash/c rng)
(coerce-contract 'hash/c rng)))
(cond
[(or flat?
(and (eq? immutable #t)
(flat-contract? dom-ctc)
(flat-contract? rng-ctc)))
(make-flat-hash/c dom-ctc rng-ctc immutable)]
[(chaperone-contract? rng-ctc)
(make-chaperone-hash/c dom-ctc rng-ctc immutable)]
[else
(make-impersonator-hash/c dom-ctc rng-ctc immutable)]))
(define (check-hash/c ctc val blame)
(define dom-ctc (base-hash/c-dom ctc))

27
collects/racket/contract/private/legacy.rkt
View File

@ -38,9 +38,12 @@
(list (blame-source blame) (blame-value blame))
(blame-contract blame)))]
[else
(error 'make-proj-contract
"expected a projection that accepts 4 or 5 arguments; got: ~e"
proj)])))
(raise-argument-error
'make-proj-contract
(format "~s" '(and/c procedure?
(λ (x) (or/c (procedure-arity-includes? x 4)
(procedure-arity-includes? x 5)))))
proj)])))
(define (contract-proc c)
(let* ([proj (contract-projection c)])
@ -71,7 +74,7 @@
(define (unpack-source info)
(cond
[(syntax? info) (build-source-location info)]
[(list? info)
[(and (list? info) (= 2 (length info)))
(let ([loc (list-ref info 0)])
(if (syntax? (srcloc-source loc))
(struct-copy
@ -83,15 +86,17 @@
(srcloc-source loc))))])
loc))]
[else
(error 'contract
"expected a syntax object or list of two elements, got: ~e"
info)]))
(raise-argument-error 'contract
(format "~s" '(or/c syntax?
(list/c any/c any/c)))
info)]))
(define (unpack-name info)
(cond
[(syntax? info) (and (identifier? info) (syntax-e info))]
[(list? info) (list-ref info 1)]
[(and (list? info) (= 2 (length info))) (list-ref info 1)]
[else
(error 'contract
"expected a syntax object or list of two elements, got: ~e"
info)]))
(raise-argument-error 'contract
(format "~s" '(or/c syntax?
(list/c any/c any/c)))
info)]))

56
collects/racket/contract/private/object.rkt
View File

@ -87,38 +87,48 @@
(define (subclass?/c %)
(unless (class? %)
(error 'subclass?/c "expected <class>, given: ~e" %))
(let ([name (object-name %)])
(flat-named-contract
`(subclass?/c ,(or name 'unknown%))
(lambda (x) (subclass? x %)))))
(raise-argument-error 'subclass?/c
'class?
%))
(define name (object-name %))
(flat-named-contract
`(subclass?/c ,(or name 'unknown%))
(lambda (x) (subclass? x %))))
(define (implementation?/c <%>)
(unless (interface? <%>)
(error 'implementation?/c "expected <interface>, given: ~e" <%>))
(let ([name (object-name <%>)])
(flat-named-contract
`(implementation?/c ,(or name 'unknown<%>))
(lambda (x) (implementation? x <%>)))))
(raise-argument-error 'implementation?/c
'interface?
<%>))
(define name (object-name <%>))
(flat-named-contract
`(implementation?/c ,(or name 'unknown<%>))
(lambda (x) (implementation? x <%>))))
(define (sub/impl?/c %/<%>)
(cond
[(interface? %/<%>) (implementation?/c %/<%>)]
[(class? %/<%>) (subclass?/c %/<%>)]
[else (error 'make-mixin-contract "unknown input ~e" %/<%>)]))
[else
(raise-argument-error
'make-mixin-contract
(format "~s" '(or/c interface? class?))
%/<%>)]))
(define (is-a?/c <%>)
(unless (or (interface? <%>)
(class? <%>))
(error 'is-a?/c "expected <interface> or <class>, given: ~e" <%>))
(let ([name (object-name <%>)])
(flat-named-contract
(cond
[name
`(is-a?/c ,name)]
[(class? <%>)
`(is-a?/c unknown%)]
[else `(is-a?/c unknown<%>)])
(lambda (x) (is-a? x <%>)))))
(unless (or (interface? <%>) (class? <%>))
(raise-argument-error
'is-a?/c
(format "~s" '(or/c interface? class?))
<%>))
(define name (object-name <%>))
(flat-named-contract
(cond
[name
`(is-a?/c ,name)]
[(class? <%>)
`(is-a?/c unknown%)]
[else `(is-a?/c unknown<%>)])
(lambda (x) (is-a? x <%>))))
(define mixin-contract (->d ([c% class?]) () [res (subclass?/c c%)]))

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

@ -393,14 +393,14 @@
(case (dep-type subcontract)
[(#:flat)
(unless (flat-contract? dep-ctc)
(error 'struct/dc "expected a flat contract for the field: ~a, got ~s"
(subcontract-field-name subcontract)
(contract-name dep-ctc)))]
(raise-argument-error 'struct/dc
(format "a flat-contract? for field ~a" (subcontract-field-name subcontract))
dep-ctc))]
[(#:chaperone)
(unless (chaperone-contract? dep-ctc)
(error 'struct/dc "expected a chaperone contract for the field: ~a, got ~s"
(subcontract-field-name subcontract)
(contract-name dep-ctc)))]))
(raise-argument-error 'struct/dc
(format "a chaperone-contract? for field ~a" (subcontract-field-name subcontract))
dep-ctc))]))
(define (struct/dc-stronger? this that)
(and (base-struct/dc? that)
@ -463,9 +463,9 @@
(when (and (indep? subcontract)
(not (mutable? subcontract)))
(unless (chaperone-contract? (indep-ctc subcontract))
(error 'struct/dc "expected chaperone contracts, but field ~a has ~e"
(subcontract-field-name subcontract)
(indep-ctc subcontract)))))
(raise-argument-error 'struct/dc
(format "a chaperone-contract? for field ~a" (subcontract-field-name subcontract))
(indep-ctc subcontract)))))
(define (flat-subcontract? subcontract)
(cond
[(indep? subcontract) (flat-contract? (indep-ctc subcontract))]

2
collects/tests/racket/contract-test.rktl
View File

@ -10613,7 +10613,7 @@
(struct/dc s [ernie integer?] [bert (new-∀/c 'α)]))
(λ (x)
(and (exn:fail? x)
(regexp-match #rx"expected chaperone" (exn-message x)))))
(regexp-match #rx"chaperone-contract[?]" (exn-message x)))))
(contract-error-test
'struct/dc-not-a-field