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

add a cons/dc generator

Browse Source 
Not really sure about this one. The API kind of
forces my hand here and the way this works limits
the non-dep side of the dependent pair to always
be drawn from a fixed set. Not sure if that matters
in practice or not.
This commit is contained in:
Robby Findler 2015-01-03 19:25:25 -06:00
parent e25575b16a
commit 95dcee18c7
2 changed files with 27 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/racket-test/tests/racket/contract-rand-test.rkt
View File

@ -50,6 +50,8 @@
(check-not-exn (λ () (test-contract-generation (=/c 0.0)))) (check-not-exn (λ () (test-contract-generation (=/c 0.0))))
(check-not-exn (λ () (test-contract-generation (or/c boolean? boolean?)))) (check-not-exn (λ () (test-contract-generation (or/c boolean? boolean?))))
(check-not-exn (λ () (test-contract-generation (cons/c integer? boolean?)))) (check-not-exn (λ () (test-contract-generation (cons/c integer? boolean?))))
(check-not-exn (λ () (test-contract-generation (cons/dc [hd integer?] [tl (hd) (<=/c hd)]))))
(check-not-exn (λ () (test-contract-generation (cons/dc [hd (tl) (<=/c tl)] [tl integer?]))))
(check-not-exn (λ () (test-contract-generation any/c))) (check-not-exn (λ () (test-contract-generation any/c)))
(check-not-exn (λ () (test-contract-generation (and/c real? (not/c negative?))))) (check-not-exn (λ () (test-contract-generation (and/c real? (not/c negative?)))))

28
racket/collects/racket/contract/private/misc.rkt
View File

@ -1049,6 +1049,25 @@
(define (cons/dc-stronger? this that) #f) (define (cons/dc-stronger? this that) #f)
(define (cons/dc-generate ctc)
(define undep-ctc (the-cons/dc-undep ctc))
(define dep-mk-ctc (the-cons/dc-dep ctc))
(define forwards? (the-cons/dc-forwards? ctc))
(λ (fuel)
(define undep-gen (contract-random-generate/choose undep-ctc fuel))
(define pair-gens
(for*/list ([i (in-range 5)]
[v (in-value (undep-gen))]
[g (in-value (contract-random-generate/choose (dep-mk-ctc v) fuel))]
#:when g)
(if forwards?
(λ () (cons v (g)))
(λ () (cons (g) v)))))
(define howmany (length pair-gens))
(and (not (zero? howmany))
(λ ()
((list-ref pair-gens (random howmany)))))))
(struct the-cons/dc (forwards? undep dep here name-info)) (struct the-cons/dc (forwards? undep dep here name-info))
(struct flat-cons/dc the-cons/dc () (struct flat-cons/dc the-cons/dc ()
@ -1058,7 +1077,8 @@
#:val-first-projection cons/dc-val-first-projection #:val-first-projection cons/dc-val-first-projection
#:name cons/dc-name #:name cons/dc-name
#:first-order cons/dc-first-order #:first-order cons/dc-first-order
#:stronger cons/dc-stronger?)) #:stronger cons/dc-stronger?
#:generate cons/dc-generate))
(struct chaperone-cons/dc the-cons/dc () (struct chaperone-cons/dc the-cons/dc ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
@ -1067,7 +1087,8 @@
#:val-first-projection cons/dc-val-first-projection #:val-first-projection cons/dc-val-first-projection
#:name cons/dc-name #:name cons/dc-name
#:first-order cons/dc-first-order #:first-order cons/dc-first-order
#:stronger cons/dc-stronger?)) #:stronger cons/dc-stronger?
#:generate cons/dc-generate))
(struct impersonator-cons/dc the-cons/dc () (struct impersonator-cons/dc the-cons/dc ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
@ -1076,7 +1097,8 @@
#:val-first-projection cons/dc-val-first-projection #:val-first-projection cons/dc-val-first-projection
#:name cons/dc-name #:name cons/dc-name
#:first-order cons/dc-first-order #:first-order cons/dc-first-order
#:stronger cons/dc-stronger?)) #:stronger cons/dc-stronger?
#:generate cons/dc-generate))
(define-syntax (cons/dc stx) (define-syntax (cons/dc stx)
(define (kwds->constructor stx) (define (kwds->constructor stx)