fix some issues surrounding the #:list-contract? argument to various contract combinator utilities
closes #1756
This commit is contained in:
parent
98a78add9f
commit
67ac06e6ed
|
@ -44,6 +44,20 @@
|
||||||
'make-contract-4
|
'make-contract-4
|
||||||
'((contract proj:add1->sub1 sqrt 'pos 'neg) 'dummy))
|
'((contract proj:add1->sub1 sqrt 'pos 'neg) 'dummy))
|
||||||
|
|
||||||
|
(test/spec-passed/result
|
||||||
|
'make-contract-5
|
||||||
|
'(list-contract?
|
||||||
|
(make-contract #:late-neg-projection (λ (b) (λ (v) (λ (neg-party) v)))))
|
||||||
|
#f)
|
||||||
|
|
||||||
|
(test/spec-passed/result
|
||||||
|
'make-contract-6
|
||||||
|
'(list-contract?
|
||||||
|
(make-contract #:late-neg-projection
|
||||||
|
(λ (b) (λ (v) (λ (neg-party) v)))
|
||||||
|
#:list-contract? "a true value"))
|
||||||
|
#t)
|
||||||
|
|
||||||
(ctest #t contract? proj:add1->sub1)
|
(ctest #t contract? proj:add1->sub1)
|
||||||
(ctest #f flat-contract? proj:add1->sub1)
|
(ctest #f flat-contract? proj:add1->sub1)
|
||||||
(ctest #f chaperone-contract? proj:add1->sub1)
|
(ctest #f chaperone-contract? proj:add1->sub1)
|
||||||
|
@ -204,6 +218,34 @@
|
||||||
(make-blame (srcloc #f #f #f #f #f) 5 (λ () 'the-name) 'pos 'neg #t))
|
(make-blame (srcloc #f #f #f #f #f) 5 (λ () 'the-name) 'pos 'neg #t))
|
||||||
5)))
|
5)))
|
||||||
|
|
||||||
|
(test/spec-passed/result
|
||||||
|
'build-chaperone-contract-property2
|
||||||
|
'(let ()
|
||||||
|
(struct odd-length-list-of-integers ()
|
||||||
|
#:property prop:chaperone-contract
|
||||||
|
(build-chaperone-contract-property
|
||||||
|
#:val-first-projection (λ (me)
|
||||||
|
(λ (blame)
|
||||||
|
(λ (val)
|
||||||
|
(λ (neg-party)
|
||||||
|
(cond
|
||||||
|
[(and (list? val)
|
||||||
|
(odd? (length val))
|
||||||
|
(andmap integer? val))
|
||||||
|
val]
|
||||||
|
[else
|
||||||
|
(raise-blame-error
|
||||||
|
blame
|
||||||
|
val
|
||||||
|
"bad")])))))
|
||||||
|
#:list-contract? (λ (c) #t)
|
||||||
|
#:name (λ (x) 'the-name)
|
||||||
|
;; make a very aproximate first-order check
|
||||||
|
#:first-order (λ (c) (λ (x) #t))
|
||||||
|
#:stronger (λ (x y) #f)))
|
||||||
|
(list-contract? (odd-length-list-of-integers)))
|
||||||
|
#t)
|
||||||
|
|
||||||
(contract-eval
|
(contract-eval
|
||||||
'(define prop:late-neg-proj:bad-prime-box-list/c
|
'(define prop:late-neg-proj:bad-prime-box-list/c
|
||||||
(let* ([prime? (λ (n)
|
(let* ([prime? (λ (n)
|
||||||
|
|
|
@ -151,7 +151,8 @@
|
||||||
#:projection [get-projection #f]
|
#:projection [get-projection #f]
|
||||||
#:stronger [stronger #f]
|
#:stronger [stronger #f]
|
||||||
#:generate [generate #f]
|
#:generate [generate #f]
|
||||||
#:exercise [exercise #f])
|
#:exercise [exercise #f]
|
||||||
|
#:list-contract? [is-list-contract? (λ (c) #f)])
|
||||||
(:build-chaperone-contract-property
|
(:build-chaperone-contract-property
|
||||||
#:name get-name
|
#:name get-name
|
||||||
#:first-order get-first-order
|
#:first-order get-first-order
|
||||||
|
@ -163,7 +164,8 @@
|
||||||
(maybe-add-wrapper add-prop-chaperone-check get-projection)
|
(maybe-add-wrapper add-prop-chaperone-check get-projection)
|
||||||
#:stronger stronger
|
#:stronger stronger
|
||||||
#:generate generate
|
#:generate generate
|
||||||
#:exercise exercise))
|
#:exercise exercise
|
||||||
|
#:list-contract? is-list-contract?))
|
||||||
build-chaperone-contract-property))
|
build-chaperone-contract-property))
|
||||||
|
|
||||||
(define (add-prop-late-neg-chaperone-check get-late-neg)
|
(define (add-prop-late-neg-chaperone-check get-late-neg)
|
||||||
|
@ -239,7 +241,7 @@
|
||||||
#:projection [projection #f]
|
#:projection [projection #f]
|
||||||
#:stronger [stronger #f]
|
#:stronger [stronger #f]
|
||||||
#:generate [generate (λ (ctc) (λ (fuel) #f))]
|
#:generate [generate (λ (ctc) (λ (fuel) #f))]
|
||||||
#:list-contract? [is-list-contract #f])
|
#:list-contract? [is-list-contract (λ (c) #f)])
|
||||||
(:build-flat-contract-property
|
(:build-flat-contract-property
|
||||||
#:name name
|
#:name name
|
||||||
#:first-order first-order
|
#:first-order first-order
|
||||||
|
|
|
@ -300,6 +300,16 @@
|
||||||
proc-name
|
proc-name
|
||||||
(build-context))))
|
(build-context))))
|
||||||
|
|
||||||
|
(unless (and (procedure? list-contract?)
|
||||||
|
(procedure-arity-includes? list-contract? 1))
|
||||||
|
(error proc-name
|
||||||
|
(string-append
|
||||||
|
"contract violation\n"
|
||||||
|
" expected: (procedure-arity-includes/c 1)\n"
|
||||||
|
" given: ~e\n"
|
||||||
|
" in the #:list-contract? argument")
|
||||||
|
list-contract?))
|
||||||
|
|
||||||
(mk (or get-name (λ (c) default-name))
|
(mk (or get-name (λ (c) default-name))
|
||||||
(or get-first-order get-any?)
|
(or get-first-order get-any?)
|
||||||
get-projection
|
get-projection
|
||||||
|
@ -453,7 +463,7 @@
|
||||||
#:stronger [stronger #f]
|
#:stronger [stronger #f]
|
||||||
#:generate [generate (λ (ctc) (λ (fuel) #f))]
|
#:generate [generate (λ (ctc) (λ (fuel) #f))]
|
||||||
#:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))]
|
#:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))]
|
||||||
#:list-contract? [list-contract? (λ (ctc) #f)])
|
#:list-contract? [list-contract? #f])
|
||||||
|
|
||||||
(unless (or first-order
|
(unless (or first-order
|
||||||
projection
|
projection
|
||||||
|
@ -486,7 +496,7 @@
|
||||||
[else late-neg-projection])
|
[else late-neg-projection])
|
||||||
(or stronger as-strong?)
|
(or stronger as-strong?)
|
||||||
generate exercise
|
generate exercise
|
||||||
list-contract?))
|
(and list-contract? #t)))
|
||||||
|
|
||||||
(define (late-neg-first-order-projection name p?)
|
(define (late-neg-first-order-projection name p?)
|
||||||
(λ (b)
|
(λ (b)
|
||||||
|
|
Loading…
Reference in New Issue
Block a user