Implement hash/c random generate and exercise
This commit is contained in:
parent
dbcc9dddc3
commit
2dc96b365a
|
@ -92,6 +92,28 @@
|
|||
(check-not-exn (λ () (test-contract-generation (*list/c boolean? number? char?))))
|
||||
(check-not-exn (λ () (test-contract-generation (-> (*list/c boolean? number? char?) any))))
|
||||
|
||||
(check-not-exn (λ () (test-contract-generation (hash/c boolean? boolean?))))
|
||||
(check-not-exn (λ () (test-contract-generation (hash/c char? integer?))))
|
||||
(check-not-exn (λ () (test-contract-generation (hash/c string? integer?))))
|
||||
(check-not-exn (λ () (test-contract-generation (hash/c string? (-> number? boolean?)))))
|
||||
(check-not-exn (λ () (test-contract-generation (hash/c string? (hash/c integer? string?)))))
|
||||
(check-not-exn (λ () (test-contract-generation (hash/c (hash/c string? integer?) (hash/c integer? string?)))))
|
||||
|
||||
(define hash/c-list
|
||||
(for/list ([i (in-range 100)])
|
||||
(contract-random-generate
|
||||
(hash/c integer? integer?))))
|
||||
|
||||
;; hash/c should periodically generate empty hashes
|
||||
(check-pred
|
||||
(λ (v) (not (empty? v)))
|
||||
(filter hash-empty? hash/c-list))
|
||||
|
||||
;; hash/c should periodically generate hashes with multiple elements
|
||||
(check-pred
|
||||
(λ (v) (not (empty? v)))
|
||||
(filter (λ (h) (> (length (hash-values h)) 1)) hash/c-list))
|
||||
|
||||
(check-not-exn
|
||||
(λ ()
|
||||
(test-contract-generation
|
||||
|
@ -493,6 +515,14 @@
|
|||
'pos
|
||||
'neg))
|
||||
|
||||
(check-exercise
|
||||
10
|
||||
pos-exn?
|
||||
(contract (hash/c symbol? (-> integer? boolean?))
|
||||
(make-hash (list (cons 'lam (λ (n) (+ n 1)))))
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
;; a test for contract-random-generate/choose
|
||||
(let ()
|
||||
(struct make-gen-choose/c ()
|
||||
|
|
|
@ -4,7 +4,10 @@
|
|||
syntax/location
|
||||
"guts.rkt"
|
||||
"blame.rkt"
|
||||
"prop.rkt")
|
||||
"prop.rkt"
|
||||
"rand.rkt"
|
||||
"generate.rkt"
|
||||
"generate-base.rkt")
|
||||
|
||||
(provide (rename-out [wrap-hash/c hash/c])
|
||||
hash/dc)
|
||||
|
@ -188,6 +191,51 @@
|
|||
(contract-struct-equivalent? this-rng that-rng))]
|
||||
[else #f]))
|
||||
|
||||
;; Will periodically generate empty hashes and hashes with multiple elements
|
||||
(define (hash/c-generate ctc)
|
||||
(define this-dom (base-hash/c-dom ctc))
|
||||
(define this-rng (base-hash/c-rng ctc))
|
||||
(define this-immutable (base-hash/c-immutable ctc))
|
||||
(λ (fuel)
|
||||
(define rnd (random fuel)) ;; used to return empty hashes from time to time
|
||||
(define gen-key (contract-random-generate/choose this-dom fuel))
|
||||
(define gen-val (contract-random-generate/choose this-rng fuel))
|
||||
(λ ()
|
||||
(cond [(or (zero? rnd) (not gen-key) (not gen-val))
|
||||
(if this-immutable
|
||||
(hash)
|
||||
(make-hash))]
|
||||
[else
|
||||
(let ([pair-list
|
||||
(let loop ([so-far (list (cons (gen-key) (gen-val)))])
|
||||
(rand-choice
|
||||
[1/5 so-far]
|
||||
[else
|
||||
(loop
|
||||
(cons (cons (gen-key) (gen-val)) so-far))]))])
|
||||
(if this-immutable
|
||||
(make-immutable-hash pair-list)
|
||||
(make-hash pair-list)))]))))
|
||||
|
||||
(define (hash/c-exercise ctc)
|
||||
(define env (contract-random-generate-get-current-environment))
|
||||
(define dom (base-hash/c-dom ctc))
|
||||
(define rng (base-hash/c-rng ctc))
|
||||
(λ (fuel)
|
||||
;; passing (list dom rng) to multi-exercise will produce
|
||||
;; a function that exercises values of form (list/c dom rng)
|
||||
;; and a list of newly available contracts.
|
||||
(define-values (exercise-list-dom-rng available-ctcs)
|
||||
((multi-exercise (list dom rng)) fuel))
|
||||
(values
|
||||
(λ (h)
|
||||
;; iterate over key-value pairs, exercise and stash
|
||||
(for ([(k v) (in-hash h)])
|
||||
(exercise-list-dom-rng (list k v))
|
||||
(contract-random-generate-stash env dom k)
|
||||
(contract-random-generate-stash env dom v)))
|
||||
(cons dom (cons rng available-ctcs)))))
|
||||
|
||||
(define-struct (flat-hash/c base-hash/c) ()
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
|
@ -195,6 +243,8 @@
|
|||
(build-flat-contract-property
|
||||
#:name hash/c-name
|
||||
#:first-order hash/c-first-order
|
||||
#:generate hash/c-generate
|
||||
#:exercise hash/c-exercise
|
||||
#:stronger hash/c-stronger
|
||||
#:equivalent hash/c-equivalent
|
||||
#:late-neg-projection
|
||||
|
@ -311,6 +361,8 @@
|
|||
(build-chaperone-contract-property
|
||||
#:name hash/c-name
|
||||
#:first-order hash/c-first-order
|
||||
#:generate hash/c-generate
|
||||
#:exercise hash/c-exercise
|
||||
#:stronger hash/c-stronger
|
||||
#:equivalent hash/c-equivalent
|
||||
#:late-neg-projection (ho-projection chaperone-hash)))
|
||||
|
|
Loading…
Reference in New Issue
Block a user