Fix default contract generation and exercise proc

The default values updated in commit ffc5720b5 do
not work for very subtle reasons. In build-contract
in racket/contract/private/prop, the default values
should not accept an extra ctc argument since ctc
is already handled by make-flat-contract. The
default gen procedure should also be (λ (fuel) #f)
instead of (λ (ctc) (λ () #f)) since the latter
would generate false when the generation should
have failed. In build-property, the default procedure
(λ (ctc) (λ (fuel) #f)) is correct and should not
be changed to (λ (ctc) (λ () #f)).
This commit is contained in:
shhyou 2018-07-31 14:20:49 -05:00 committed by Robby Findler
parent 59f49cb6ff
commit aeab2420fa
2 changed files with 31 additions and 8 deletions

View File

@ -413,11 +413,34 @@
(check-exercise 2 void? even-list/c)
(check-exercise 2 void? even-list/c/generate))
(check-false
(contract-random-generate
(make-chaperone-contract
#:late-neg-projection
(λ (b) (λ (f v np) v)))))
(let () ;; test the default value of generate / exercise for make-chaperone-contract
(define custom-any/c
(make-chaperone-contract
#:late-neg-projection
(λ (b) (λ (v np) v))))
(define any->any/c
(make-chaperone-contract
#:late-neg-projection
(λ (b)
(λ (v np)
(chaperone-procedure v values impersonator-prop:contracted any->any/c)))))
(define/contract proc any->any/c values)
(check-exn cannot-generate-exn? (λ () (test-contract-generation custom-any/c)))
(check-not-exn (λ () (contract-exercise proc))))
(let ()
(struct impersonate-any/c-struct ()
#:property prop:contract
(build-contract-property
#:late-neg-projection
(λ (ctc) (λ (b) (λ (v np) v)))))
(define impersonate-any/c (impersonate-any/c-struct))
(check-exn cannot-generate-exn? (λ () (test-contract-generation impersonate-any/c)))
(check-exn cannot-generate-exn?
(λ ()
(test-contract-generation
(->i ([n integer?])
[_ (n) (λ (r) (eq? r (even? n)))])))))
(check-exercise
10

View File

@ -298,7 +298,7 @@
#:late-neg-projection [get-late-neg-projection #f]
#:stronger [stronger #f]
#:equivalent [equivalent #f]
#:generate [generate (λ (ctc) (λ () #f))]
#:generate [generate (λ (ctc) (λ (fuel) #f))]
#:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))]
#:list-contract? [list-contract? (λ (c) #f)])
(unless (or get-first-order
@ -476,8 +476,8 @@
#:late-neg-projection [late-neg-projection #f]
#:stronger [stronger #f]
#:equivalent [equivalent #f]
#:generate [generate (λ (ctc) (λ () #f))]
#:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))]
#:generate [generate (λ (fuel) #f)]
#:exercise [exercise (λ (fuel) (values void '()))]
#:list-contract? [list-contract? #f])
(unless (or first-order