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

contract random cleanup

Browse Source 
- remove excess printf
- fix indentation
- remove unused frequency tables
- adjust the generate table to avoid the imperative registration
This commit is contained in:
Robby Findler 2011-11-25 14:40:25 -06:00
parent 1ac7e7e19d
commit d672a0699e
3 changed files with 93 additions and 143 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

111
collects/racket/contract/private/generate-base.rkt
View File

@ -1,16 +1,11 @@
#lang racket/base
(require "rand.rkt")
(provide
make-generate-ctc-fail
generate-ctc-fail?
find-generate
add-generate
print-freq
get-freq
merge-freq
count-missing-generate
get-arg-names-space
gen-arg-names
env-item
@ -24,20 +19,77 @@
;; generate failure type
(define-struct generate-ctc-fail ())
;; hash tables
(define freq-hash (make-hash))
(define gen-hash (make-hash))
(define (gen-char fuel)
(let* ([gen (oneof (list (rand-range 0 55295)
(rand-range 57344 1114111)))])
(integer->char gen)))
(define gen-hash
(hash
;; generate integer?
integer?
(λ (fuel)
(rand-choice
[1/10 0]
[1/10 1]
[1/10 -1]
[1/10 2147483647]
[1/10 -2147483648]
[3/10 (rand-range -100 200)]
[else (rand-range -1000000000 2000000000)]))
exact-nonnegative-integer?
(λ (fuel)
(abs ((find-generate integer?) fuel)))
positive?
(λ (fuel)
(rand-choice
[1/10 1]
[1/10 1/3]
[1/10 0.12]
[1/10 2147483647]
[else 4]))
boolean?
(λ (fuel)
(rand-choice
[1/2 #t]
[else #f]))
char?
gen-char
string?
(λ (fuel)
(let* ([len (rand-choice [1/10 0]
[1/10 1]
[else (rand-range 2 260)])]
[strl (build-list len (λ (x) (gen-char fuel)))])
(apply string strl)))
byte?
(λ (fuel)
(rand 256))
bytes?
(λ (fuel)
(let* ([len (rand-choice
[1/10 0]
[1/10 1]
[else (+ 2 (rand 260))])]
[bstr (build-list len
(λ (x)
(rand 256)))])
(apply bytes bstr)))))
;; thread-cell
(define arg-names-count (make-thread-cell 0))
;; given a predicate returns a generate for this predicate or generate-ctc-fail
(define (find-generate func [name "internal"])
(hash-ref gen-hash func (make-generate-ctc-fail)))
(define (add-generate ctc gen)
(hash-set! gen-hash ctc gen))
(hash-ref gen-hash func make-generate-ctc-fail))
(define (get-arg-names-space space-needed)
(let ([rv (thread-cell-ref arg-names-count)])
@ -50,33 +102,4 @@
[else (cons (string->symbol (string-append "x-" (number->string st-num)))
(gen-arg-names (+ st-num 1) (- size 1)))]))
(define (print-freq)
(let* ([l (hash-map freq-hash (λ (k v)
(list k v)))]
[l-s (sort l (λ (e1 e2)
(> (list-ref e1 1)
(list-ref e2 1))))])
(map (λ (x)
(printf "# ~a : ~a\n"
(list-ref x 1)
(list-ref x 0)))
l-s))
null)
(define (count-missing-generate ctc)
(hash-update! freq-hash
ctc
(λ (x)
(+ x 1))
0))
(define (get-freq)
freq-hash)
(define (merge-freq h)
(hash-for-each h (λ (k v)
(hash-set! freq-hash k (+ (hash-ref freq-hash k 0)
v)))))

121
collects/racket/contract/private/generate.rkt
View File

@ -8,12 +8,12 @@
(provide generate-env
env-stash
contract-random-generate
generate/direct
generate/choose
make-generate-ctc-fail
generate-ctc-fail?)
@ -26,76 +26,6 @@
(let* ([curvals (hash-ref env ctc (list))])
(hash-set! env ctc (cons val curvals))))
;; hash tables
;(define freq-hash (make-hash))
;(define gen-hash (make-hash))
;; thread-cell
;(define arg-names-count (make-thread-cell 0))
;; generate integer?
(add-generate integer?
(λ (fuel)
(rand-choice
[1/10 0]
[1/10 1]
[1/10 -1]
[1/10 2147483647]
[1/10 -2147483648]
[3/10 (rand-range -100 200)]
[else (rand-range -1000000000 2000000000)])))
(add-generate exact-nonnegative-integer?
(λ (fuel)
(abs ((find-generate integer?) fuel))))
(add-generate positive?
(λ (fuel)
(rand-choice
[1/10 1]
[1/10 1/3]
[1/10 0.12]
[1/10 2147483647]
[else 4])))
(add-generate boolean?
(λ (fuel)
(rand-choice
[1/2 #t]
[else #f])))
(add-generate char?
(λ (fuel)
(let* ([gen (oneof (list (rand-range 0 55295)
(rand-range 57344 1114111)))])
(integer->char gen))))
(add-generate string?
(λ (fuel)
(let* ([len (rand-choice [1/10 0]
[1/10 1]
[else (rand-range 2 260)])]
[strl (build-list len
(λ (x)
(gen-pred/direct char? fuel)))])
(apply string strl))))
(add-generate byte?
(λ (fuel)
(rand 256)))
(add-generate bytes?
(λ (fuel)
(let* ([len (rand-choice
[1/10 0]
[1/10 1]
[else (+ 2 (rand 260))])]
[bstr (build-list len
(λ (x)
(rand 256)))])
(apply bytes bstr))))
(define (gen-pred/direct pred fuel)
(let ([ctc (coerce-contract 'contract-direct-gen pred)])
(generate/direct ctc fuel)))
@ -108,7 +38,6 @@
(contract-struct-name
(coerce-contract 'contract-random-generate ctc))))])
(let ([def-ctc (coerce-contract 'contract-random-generate ctc)])
(printf "def-ctc ~s\n" def-ctc)
(parameterize ([generate-env (make-hash)])
; choose randomly
(let ([val (generate/choose def-ctc fuel)])
@ -119,18 +48,18 @@
; Iterates through generation methods until failure. Returns
; generate-ctc-fail if no value could be generated
(define (generate/choose ctc fuel)
(let ([options (permute (list generate/direct
generate/direct-env
))])
; choose randomly
(let trygen ([options options])
(if (empty? options)
(make-generate-ctc-fail)
(let* ([option (car options)]
[val (option ctc fuel)])
(if (generate-ctc-fail? val)
(trygen (cdr options))
val))))))
(let ([options (permute (list generate/direct
generate/direct-env
))])
; choose randomly
(let trygen ([options options])
(if (empty? options)
(make-generate-ctc-fail)
(let* ([option (car options)]
[val (option ctc fuel)])
(if (generate-ctc-fail? val)
(trygen (cdr options))
val))))))
; generate/direct :: contract int -> value for contract
; Attempts to make a generator that generates values for this contract
@ -139,9 +68,9 @@
(let ([g (contract-struct-generate ctc)])
; Check if the contract has a direct generate attached
(if (generate-ctc-fail? g)
; Everything failed -- we can't directly generate this ctc
g
(g fuel))))
; Everything failed -- we can't directly generate this ctc
g
(g fuel))))
; generate/direct-env :: contract int -> value
; Attemps to find a value with the given contract in the environment.
@ -150,19 +79,19 @@
; TODO: find out how to make negative test cases
(let* ([keys (hash-keys (generate-env))]
[valid-ctcs (filter (λ (c)
(contract-stronger? c ctc))
(contract-stronger? c ctc))
keys)])
(if (> (length valid-ctcs) 0)
(oneof (oneof (map (λ (key)
(hash-ref (generate-env) key))
valid-ctcs)))
(make-generate-ctc-fail))))
(oneof (oneof (map (λ (key)
(hash-ref (generate-env) key))
valid-ctcs)))
(make-generate-ctc-fail))))
; generate/indirect-env :: contract int -> (int -> value for contract)
; Attempts to make a generator that generates values for this contract
; by calling functions in the environment
(define (generate/indirect-env ctc fuel)
(if (> fuel 0)
(make-generate-ctc-fail)
(make-generate-ctc-fail)))
(make-generate-ctc-fail)
(make-generate-ctc-fail)))

4
collects/racket/contract/private/prop.rkt
View File

@ -82,9 +82,7 @@
(if (procedure? generate)
; FIXME: Call needs to take multiple arguments
(generate c)
(begin
(count-missing-generate (contract-struct-name c))
(make-generate-ctc-fail)))))
(make-generate-ctc-fail))))
(define (contract-struct-exercise c)
(let* ([prop (contract-struct-property c)]