improve contract random generation for null? and recursive-contract

This commit is contained in:
Robby Findler 2015-01-03 17:16:15 -06:00
parent cd747e3fb1
commit e25575b16a
3 changed files with 27 additions and 2 deletions

View File

@ -74,6 +74,17 @@
(or/c (cons/c any/c (cons/c any/c even-length-list/c)) (or/c (cons/c any/c (cons/c any/c even-length-list/c))
'()))))) '())))))
(check-not-exn
(λ ()
(test-contract-generation
null?)))
(check-not-exn
(λ ()
(test-contract-generation
(letrec ([c (or/c null? (cons/c real? (recursive-contract c)))])
c))))
(check-not-exn (check-not-exn
(λ () (λ ()
(struct s (a b) #:transparent) (struct s (a b) #:transparent)

View File

@ -13,7 +13,9 @@
"blame.rkt" "blame.rkt"
"prop.rkt" "prop.rkt"
"arrow.rkt" "arrow.rkt"
"misc.rkt") "misc.rkt"
"generate.rkt"
)
(define-for-syntax lifted-ccrs (make-hasheq)) (define-for-syntax lifted-ccrs (make-hasheq))
@ -182,7 +184,15 @@
(contract-first-order-passes? (force-recursive-contract ctc) (contract-first-order-passes? (force-recursive-contract ctc)
val)) val))
(struct recursive-contract ([name #:mutable] thunk [ctc #:mutable] list-contract?) (define (recursive-contract-generate ctc)
(λ (fuel)
(cond
[(zero? fuel) #f]
[else
(force-recursive-contract ctc)
(contract-random-generate/choose (recursive-contract-ctc ctc) (- fuel 1))])))
(struct recursive-contract ([name #:mutable] [thunk #:mutable] [ctc #:mutable] list-contract?)
#:property prop:recursive-contract (λ (this) #:property prop:recursive-contract (λ (this)
(force-recursive-contract this) (force-recursive-contract this)
(recursive-contract-ctc this))) (recursive-contract-ctc this)))
@ -195,6 +205,7 @@
#:first-order recursive-contract-first-order #:first-order recursive-contract-first-order
#:projection recursive-contract-projection #:projection recursive-contract-projection
#:stronger recursive-contract-stronger #:stronger recursive-contract-stronger
#:generate recursive-contract-generate
#:list-contract? recursive-contract-list-contract?)) #:list-contract? recursive-contract-list-contract?))
(struct chaperone-recursive-contract recursive-contract () (struct chaperone-recursive-contract recursive-contract ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
@ -204,6 +215,7 @@
#:first-order recursive-contract-first-order #:first-order recursive-contract-first-order
#:projection recursive-contract-projection #:projection recursive-contract-projection
#:stronger recursive-contract-stronger #:stronger recursive-contract-stronger
#:generate recursive-contract-generate
#:list-contract? recursive-contract-list-contract?)) #:list-contract? recursive-contract-list-contract?))
(struct impersonator-recursive-contract recursive-contract () (struct impersonator-recursive-contract recursive-contract ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
@ -213,4 +225,5 @@
#:first-order recursive-contract-first-order #:first-order recursive-contract-first-order
#:projection recursive-contract-projection #:projection recursive-contract-projection
#:stronger recursive-contract-stronger #:stronger recursive-contract-stronger
#:generate recursive-contract-generate
#:list-contract? recursive-contract-list-contract?)) #:list-contract? recursive-contract-list-contract?))

View File

@ -232,6 +232,7 @@
[(contract-struct? x) #f] ;; this has to come first, since some of these are procedure?. [(contract-struct? x) #f] ;; this has to come first, since some of these are procedure?.
[(and (procedure? x) (procedure-arity-includes? x 1)) [(and (procedure? x) (procedure-arity-includes? x 1))
(cond (cond
[(eq? x null?) list/c-empty]
[(and (eq? x list?) listof-any) listof-any] [(and (eq? x list?) listof-any) listof-any]
[(and (eq? x pair?) consc-anyany) consc-anyany] [(and (eq? x pair?) consc-anyany) consc-anyany]
[else [else