adjust contract library to call raise-argument-error instead of error
and a few other changes nearby to clean up various things closes PR 13623
This commit is contained in:
Robby Findler
parent
0e42a791a7
commit
6e4d483403
|
|
@ -88,54 +88,54 @@
|
|||
|
||||
;; coerce-flat-contract : symbol any/c -> contract
|
||||
(define (coerce-flat-contract name x)
|
||||
(let ([ctc (coerce-contract/f x)])
|
||||
(unless (flat-contract-struct? ctc)
|
||||
(error name
|
||||
"expected a flat contract or a value that can be coerced into one, got ~e"
|
||||
x))
|
||||
ctc))
|
||||
(define ctc (coerce-contract/f x))
|
||||
(unless (flat-contract-struct? ctc)
|
||||
(raise-argument-error name 'flat-contract? x))
|
||||
ctc)
|
||||
|
||||
;; coerce-flat-contacts : symbol (listof any/c) -> (listof flat-contract)
|
||||
;; like coerce-contracts, but insists on flat-contracts
|
||||
(define (coerce-flat-contracts name xs)
|
||||
(for/list ([x (in-list xs)]
|
||||
[i (in-naturals)])
|
||||
(let ([ctc (coerce-contract/f x)])
|
||||
(unless (flat-contract-struct? ctc)
|
||||
(error name
|
||||
"expected all of the arguments to be flat contracts, but argument ~a was not, got ~e"
|
||||
i
|
||||
x))
|
||||
ctc)))
|
||||
(define ctc (coerce-contract/f x))
|
||||
(unless (flat-contract-struct? ctc)
|
||||
(raise-argument-error name
|
||||
'flat-contract?
|
||||
i
|
||||
xs))
|
||||
ctc))
|
||||
|
||||
;; coerce-chaperone-contract : symbol any/c -> contract
|
||||
(define (coerce-chaperone-contract name x)
|
||||
(let ([ctc (coerce-contract/f x)])
|
||||
(unless (chaperone-contract-struct? ctc)
|
||||
(error name
|
||||
"expected a chaperone contract or a value that can be coerced into one, got ~e"
|
||||
x))
|
||||
ctc))
|
||||
(define ctc (coerce-contract/f x))
|
||||
(unless (chaperone-contract-struct? ctc)
|
||||
(raise-argument-error
|
||||
name
|
||||
'chaperone-contract?
|
||||
x))
|
||||
ctc)
|
||||
|
||||
;; coerce-chaperone-contacts : symbol (listof any/c) -> (listof flat-contract)
|
||||
;; like coerce-contracts, but insists on chaperone-contracts
|
||||
(define (coerce-chaperone-contracts name xs)
|
||||
(for/list ([x (in-list xs)]
|
||||
[i (in-naturals)])
|
||||
(let ([ctc (coerce-contract/f x)])
|
||||
(unless (chaperone-contract-struct? ctc)
|
||||
(error name
|
||||
"expected all of the arguments to be chaperone contracts, but argument ~a was not, got ~e"
|
||||
i
|
||||
x))
|
||||
ctc)))
|
||||
(define ctc (coerce-contract/f x))
|
||||
(unless (chaperone-contract-struct? ctc)
|
||||
(apply raise-argument-error
|
||||
name
|
||||
'chaperone-contract?
|
||||
i
|
||||
xs))
|
||||
ctc))
|
||||
|
||||
;; coerce-contract : symbol any/c -> contract
|
||||
(define (coerce-contract name x)
|
||||
(or (coerce-contract/f x)
|
||||
(error name
|
||||
"expected contract or a value that can be coerced into one, got ~e"
|
||||
x)))
|
||||
(raise-argument-error name
|
||||
'contract?
|
||||
x)))
|
||||
|
||||
;; coerce-contracts : symbols (listof any) -> (listof contract)
|
||||
;; turns all of the arguments in 'xs' into contracts
|
||||
|
|
@ -144,13 +144,14 @@
|
|||
(define (coerce-contracts name xs)
|
||||
(for/list ([x (in-list xs)]
|
||||
[i (in-naturals)])
|
||||
(let ([ctc (coerce-contract/f x)])
|
||||
(unless ctc
|
||||
(error name
|
||||
"expected all of the arguments to be contracts, but argument ~a was not, got ~e"
|
||||
i
|
||||
x))
|
||||
ctc)))
|
||||
(define ctc (coerce-contract/f x))
|
||||
(unless ctc
|
||||
(apply raise-argument-error
|
||||
name
|
||||
"contract?"
|
||||
i
|
||||
xs))
|
||||
ctc))
|
||||
|
||||
;; coerce-contract/f : any -> (or/c #f contract?)
|
||||
;; returns #f if the argument could not be coerced to a contract
|
||||
|
|
@ -271,7 +272,8 @@
|
|||
#:first-order (λ (ctc) (λ (x) (eq? (eq-contract-val ctc) x)))
|
||||
#:name
|
||||
(λ (ctc)
|
||||
(if (symbol? (eq-contract-val ctc))
|
||||
(if (or (null? (eq-contract-val ctc))
|
||||
(symbol? (eq-contract-val ctc)))
|
||||
`',(eq-contract-val ctc)
|
||||
(eq-contract-val ctc)))
|
||||
#:generate
|
||||
|
|
|
|||
|
|
@ -59,12 +59,9 @@
|
|||
(with-syntax ([(ctc-id ...) (generate-temporaries (syntax (ctc ...)))]
|
||||
[(pred-id ...) (generate-temporaries (syntax (ctc ...)))])
|
||||
(syntax
|
||||
(let* ([pred (λ (x) (error 'flat-rec-contract "applied too soon"))]
|
||||
(let* ([pred flat-rec-contract/init]
|
||||
[name (flat-contract (let ([name (λ (x) (pred x))]) name))])
|
||||
(let ([ctc-id (coerce-contract 'flat-rec-contract ctc)] ...)
|
||||
(unless (flat-contract? ctc-id)
|
||||
(error 'flat-rec-contract "expected flat contracts as arguments, got ~e" ctc-id))
|
||||
...
|
||||
(let ([ctc-id (coerce-flat-contract 'flat-rec-contract ctc)] ...)
|
||||
(set! pred
|
||||
(let ([pred-id (flat-contract-predicate ctc-id)] ...)
|
||||
(λ (x)
|
||||
|
|
@ -73,6 +70,8 @@
|
|||
[(_ name ctc ...)
|
||||
(raise-syntax-error 'flat-rec-contract "expected first argument to be an identifier" stx (syntax name))]))
|
||||
|
||||
(define (flat-rec-contract/init x) (error 'flat-rec-contract "applied too soon"))
|
||||
|
||||
(define-syntax (flat-murec-contract stx)
|
||||
(syntax-case stx ()
|
||||
[(_ ([name ctc ...] ...) body1 body ...)
|
||||
|
|
@ -83,14 +82,9 @@
|
|||
[((pred-arm-id ...) ...) (map generate-temporaries
|
||||
(syntax->list (syntax ((ctc ...) ...))))])
|
||||
(syntax
|
||||
(let* ([pred-id (λ (x) (error 'flat-murec-contract "applied too soon"))] ...
|
||||
(let* ([pred-id flat-murec-contract/init] ...
|
||||
[name (flat-contract (let ([name (λ (x) (pred-id x))]) name))] ...)
|
||||
(let-values ([(ctc-id ...) (values (coerce-contract 'flat-rec-contract ctc) ...)] ...)
|
||||
(begin
|
||||
(void)
|
||||
(unless (flat-contract? ctc-id)
|
||||
(error 'flat-rec-contract "expected flat contracts as arguments, got ~e" ctc-id))
|
||||
...) ...
|
||||
(let-values ([(ctc-id ...) (values (coerce-flat-contract 'flat-rec-contract ctc) ...)] ...)
|
||||
(set! pred-id
|
||||
(let ([pred-arm-id (flat-contract-predicate ctc-id)] ...)
|
||||
(λ (x)
|
||||
|
|
@ -106,6 +100,8 @@
|
|||
[(_ ([name ctc ...] ...))
|
||||
(raise-syntax-error 'flat-rec-contract "expected at least one body expression" stx)]))
|
||||
|
||||
(define (flat-murec-contract/init x) (error 'flat-murec-contract "applied too soon"))
|
||||
|
||||
(define/subexpression-pos-prop or/c
|
||||
(case-lambda
|
||||
[() (make-none/c '(or/c))]
|
||||
|
|
@ -421,20 +417,23 @@
|
|||
(define false/c #f)
|
||||
|
||||
(define/final-prop (string-len/c n)
|
||||
(unless (number? n)
|
||||
(error 'string-len/c "expected a number as argument, got ~e" n))
|
||||
(unless (real? n)
|
||||
(raise-argument-error 'string-len/c "real?" n))
|
||||
(flat-named-contract
|
||||
`(string-len/c ,n)
|
||||
(λ (x)
|
||||
(and (string? x)
|
||||
((string-length x) . < . n)))))
|
||||
|
||||
(define/final-prop (symbols . ss)
|
||||
(unless ((length ss) . >= . 1)
|
||||
(error 'symbols "expected at least one argument"))
|
||||
(unless (andmap symbol? ss)
|
||||
(error 'symbols "expected symbols as arguments, given: ~a"
|
||||
(apply string-append (map (λ (x) (format "~e " x)) ss))))
|
||||
(define/final-prop (symbols s1 . s2s)
|
||||
(define ss (cons s1 s2s))
|
||||
(for ([arg (in-list ss)]
|
||||
[i (in-naturals)])
|
||||
(unless (symbol? arg)
|
||||
(raise-argument-error 'symbols
|
||||
"symbol?"
|
||||
i
|
||||
ss)))
|
||||
(apply or/c ss))
|
||||
|
||||
(define atomic-value?
|
||||
|
|
@ -445,54 +444,22 @@
|
|||
(void? x) (eq? x undefined)))))
|
||||
|
||||
(define/final-prop (one-of/c . elems)
|
||||
(unless (andmap atomic-value? elems)
|
||||
(error 'one-of/c "expected chars, symbols, booleans, null, keywords, numbers, void, or undefined, got ~e"
|
||||
elems))
|
||||
(if (or (member (void) elems)
|
||||
(member (letrec ([x x]) x) elems))
|
||||
(make-one-of/c elems)
|
||||
(apply or/c elems)))
|
||||
|
||||
(define (one-of-pc x)
|
||||
(cond
|
||||
[(symbol? x)
|
||||
`',x]
|
||||
[(null? x)
|
||||
''()]
|
||||
[(void? x)
|
||||
'(void)]
|
||||
[(or (char? x)
|
||||
(boolean? x)
|
||||
(keyword? x)
|
||||
(number? x))
|
||||
x]
|
||||
[(eq? x (letrec ([x x]) x))
|
||||
'(letrec ([x x]) x)]
|
||||
[else (error 'one-of-pc "undef ~s" x)]))
|
||||
|
||||
|
||||
(define-struct one-of/c (elems)
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:flat-contract
|
||||
(build-flat-contract-property
|
||||
#:name
|
||||
(λ (ctc)
|
||||
(let ([elems (one-of/c-elems ctc)])
|
||||
`(one-of/c ,@(map one-of-pc elems))))
|
||||
|
||||
#:stronger
|
||||
(λ (this that)
|
||||
(and (one-of/c? that)
|
||||
(let ([this-elems (one-of/c-elems this)]
|
||||
[that-elems (one-of/c-elems that)])
|
||||
(and
|
||||
(andmap (λ (this-elem) (memv this-elem that-elems))
|
||||
this-elems)
|
||||
#t))))
|
||||
#:first-order
|
||||
(λ (ctc)
|
||||
(let ([elems (one-of/c-elems ctc)])
|
||||
(λ (x) (memv x elems))))))
|
||||
(for ([arg (in-list elems)]
|
||||
[i (in-naturals)])
|
||||
(unless (atomic-value? arg)
|
||||
(raise-argument-error 'one-of/c
|
||||
"char, symbol, boolean, null, keyword, number, void, or undefined"
|
||||
i
|
||||
elems)))
|
||||
(define (undefined? x) (eq? x (letrec ([x x]) x)))
|
||||
(define or/c-args
|
||||
(map (λ (x)
|
||||
(cond
|
||||
[(void? x) void?]
|
||||
[(undefined? x) undefined?]
|
||||
[else x]))
|
||||
elems))
|
||||
(apply or/c or/c-args))
|
||||
|
||||
(define-struct between/c (low high)
|
||||
#:omit-define-syntaxes
|
||||
|
|
@ -537,13 +504,9 @@
|
|||
(+ (random (- upper lower))
|
||||
lower))))))
|
||||
|
||||
(define-syntax (check-unary-between/c stx)
|
||||
(syntax-case stx ()
|
||||
[(_ 'sym x-exp)
|
||||
(identifier? #'sym)
|
||||
#'(let ([x x-exp])
|
||||
(unless (real? x)
|
||||
(error 'sym "expected a real number, got ~e" x)))]))
|
||||
(define (check-unary-between/c sym x)
|
||||
(unless (real? x)
|
||||
(raise-argument-error sym "real?" x)))
|
||||
|
||||
(define/final-prop (=/c x)
|
||||
(check-unary-between/c '=/c x)
|
||||
|
|
@ -555,15 +518,11 @@
|
|||
(check-unary-between/c '>=/c x)
|
||||
(make-between/c x +inf.0))
|
||||
(define (check-between/c x y)
|
||||
(unless (real? x)
|
||||
(error 'between/c "expected a real number as first argument, got ~e, other arg ~e" x y))
|
||||
(unless (real? y)
|
||||
(error 'between/c "expected a real number as second argument, got ~e, other arg ~e" y x)))
|
||||
(check-two-args 'between/c x y real? real?))
|
||||
(define/final-prop (between/c x y)
|
||||
(check-between/c x y)
|
||||
(make-between/c x y))
|
||||
|
||||
|
||||
(define (</c x)
|
||||
(flat-named-contract
|
||||
`(</c ,x)
|
||||
|
|
@ -590,23 +549,27 @@
|
|||
(+ (random (- max-n lower))
|
||||
lower)))))
|
||||
|
||||
(define (check-two-args name arg1 arg2 pred1? pred2?)
|
||||
(unless (pred1? arg1)
|
||||
(raise-argument-error name
|
||||
(format "~a" (object-name pred1?))
|
||||
0
|
||||
(list arg1 arg2)))
|
||||
(unless (pred2? arg2)
|
||||
(raise-argument-error name
|
||||
(format "~a" (object-name pred2?))
|
||||
1
|
||||
(list arg1 arg2))))
|
||||
(define/final-prop (integer-in start end)
|
||||
(unless (and (integer? start)
|
||||
(exact? start)
|
||||
(integer? end)
|
||||
(exact? end))
|
||||
(error 'integer-in "expected two exact integers as arguments, got ~e and ~e" start end))
|
||||
(check-two-args 'integer-in start end exact-integer? exact-integer?)
|
||||
(flat-named-contract
|
||||
`(integer-in ,start ,end)
|
||||
(λ (x)
|
||||
(and (integer? x)
|
||||
(exact? x)
|
||||
(and (exact-integer? x)
|
||||
(<= start x end)))))
|
||||
|
||||
(define/final-prop (real-in start end)
|
||||
(unless (and (real? start)
|
||||
(real? end))
|
||||
(error 'real-in "expected two real numbers as arguments, got ~e and ~e" start end))
|
||||
(check-two-args 'real start end real? real?)
|
||||
(between/c start end))
|
||||
|
||||
(define/final-prop (not/c f)
|
||||
|
|
@ -1166,9 +1129,11 @@
|
|||
[(flat-contract? predicate)
|
||||
(make-predicate-contract name (flat-contract-predicate predicate) generate)]
|
||||
[else
|
||||
(error 'flat-named-contract
|
||||
"expected a flat contract or procedure of arity 1 as second argument, got ~e"
|
||||
predicate)])))
|
||||
(raise-argument-error 'flat-named-contract
|
||||
(format "~s" `(or/c flat-contract?
|
||||
(and/c procedure?
|
||||
(λ (x) (procedure-arity-include? x 1)))))
|
||||
predicate)])))
|
||||
|
||||
(define printable/c
|
||||
(flat-named-contract
|
||||
|
|
|
|||
|
|
@ -240,7 +240,7 @@ between @racket[j] and @racket[k], inclusive.}
|
|||
A flat contract that requires the input to be an exact non-negative integer.}
|
||||
|
||||
|
||||
@defproc[(string-len/c [len exact-nonnegative-integer?]) flat-contract?]{
|
||||
@defproc[(string-len/c [len real?]) flat-contract?]{
|
||||
|
||||
Returns a flat contract that recognizes strings that have fewer than
|
||||
@racket[len] characters.}
|
||||
|
|
|
|||
|
|
@ -9639,7 +9639,7 @@
|
|||
|
||||
(test/no-error '(syntax/c (list/c #f)))
|
||||
(contract-error-test 'syntax/c-non-flat '(syntax/c (vector/c #f))
|
||||
(λ (x) (regexp-match #rx"expected a flat contract" (exn-message x))))
|
||||
(λ (x) (regexp-match? #rx"flat-contract[?]" (exn-message x))))
|
||||
|
||||
|
||||
;
|
||||
|
|
@ -12251,6 +12251,7 @@ so that propagation occurs.
|
|||
(test-name '(unconstrained-domain-> number?) (unconstrained-domain-> number?))
|
||||
|
||||
(test-name '(or/c) (or/c))
|
||||
(test-name '(or/c '()) (or/c '()))
|
||||
(test-name '(or/c integer? gt0?) (or/c integer? (let ([gt0? (lambda (x) (> x 0))]) gt0?)))
|
||||
(test-name '(or/c integer? boolean?)
|
||||
(or/c (flat-contract integer?)
|
||||
|
|
@ -12303,7 +12304,7 @@ so that propagation occurs.
|
|||
(test-name 'printable/c printable/c)
|
||||
(test-name '(or/c 'a 'b 'c) (symbols 'a 'b 'c))
|
||||
(test-name '(or/c 1 2 3) (one-of/c 1 2 3))
|
||||
(test-name '(one-of/c '() 'x 1 #f #\a (void) (letrec ([x x]) x))
|
||||
(test-name '(or/c '() 'x 1 #f #\a void? undefined?)
|
||||
(one-of/c '() 'x 1 #f #\a (void) (letrec ([x x]) x)))
|
||||
|
||||
(test-name '(or/c #f #t #\a "x") (or/c #f #t #\a "x"))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user