some work on random generation from contracts
This commit is contained in:
Robby Findler
parent
0ce0abb2c2
commit
1cb1ff284b
|
|
@ -1,60 +1,44 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/contract
|
||||
racket/contract/private/generate-base
|
||||
rackunit
|
||||
rackunit/text-ui
|
||||
net/url)
|
||||
|
||||
(define (test-contract-generation ctc
|
||||
[monkey-with values]
|
||||
#:size [size 10])
|
||||
;; this is expected to never have a generator.
|
||||
(define (some-crazy-predicate? x) (and (number? x) (= x 11)))
|
||||
|
||||
(define (test-contract-generation ctc #:size [size 10])
|
||||
(define example-vals (contract-random-generate ctc size))
|
||||
(monkey-with (contract ctc example-vals 'pos 'neg)))
|
||||
(contract ctc example-vals 'pos 'neg))
|
||||
|
||||
(define pred-tests
|
||||
(test-suite
|
||||
"Predicate contract"
|
||||
(check-not-exn (λ () (test-contract-generation integer?)))
|
||||
(check-not-exn (λ () (test-contract-generation exact-nonnegative-integer?)))
|
||||
(check-not-exn (λ () (test-contract-generation boolean?)))
|
||||
(check-not-exn (λ () (test-contract-generation char?)))
|
||||
(check-not-exn (λ () (test-contract-generation byte?)))
|
||||
(check-not-exn (λ () (test-contract-generation bytes?)))
|
||||
(check-not-exn (λ () (test-contract-generation string?)))
|
||||
))
|
||||
(for ([(k v) (in-hash predicate-generator-table)])
|
||||
(check-not-exn (λ () (test-contract-generation k))))
|
||||
|
||||
(define flat-ctc-tests
|
||||
(test-suite
|
||||
"Built-in flat contracts"
|
||||
(check-not-exn (λ () (test-contract-generation (between/c 1 100))))
|
||||
(check-not-exn (λ () (test-contract-generation (listof integer?))))
|
||||
(check-not-exn (λ () (test-contract-generation (>=/c 0))))
|
||||
(check-not-exn (λ () (test-contract-generation (<=/c 0))))
|
||||
(check-not-exn (λ () (test-contract-generation (>/c 0))))
|
||||
(check-not-exn (λ () (test-contract-generation (</c 0))))
|
||||
(check-not-exn (λ () (test-contract-generation (or/c boolean? boolean?))))
|
||||
))
|
||||
(check-not-exn (λ () (test-contract-generation (listof boolean?))))
|
||||
(check-not-exn (λ () (test-contract-generation (listof number?))))
|
||||
|
||||
(define func-tests
|
||||
(test-suite
|
||||
"Function contracts"
|
||||
(check-exn exn:fail? (λ ()
|
||||
((test-contract-generation (-> char?
|
||||
integer?)) 0)))
|
||||
(check-not-exn (λ () ((test-contract-generation (-> integer?
|
||||
integer?)) 1)))
|
||||
(check-not-exn (λ () ((test-contract-generation
|
||||
(-> (-> integer?
|
||||
integer?)
|
||||
boolean?))
|
||||
+)))))
|
||||
(check-not-exn (λ () (test-contract-generation (between/c 1 100))))
|
||||
(check-not-exn (λ () (test-contract-generation (listof integer?))))
|
||||
(check-not-exn (λ () (test-contract-generation (>=/c 0))))
|
||||
(check-not-exn (λ () (test-contract-generation (<=/c 0))))
|
||||
(check-not-exn (λ () (test-contract-generation (>/c 0))))
|
||||
(check-not-exn (λ () (test-contract-generation (</c 0))))
|
||||
(check-not-exn (λ () (test-contract-generation (or/c boolean? boolean?))))
|
||||
|
||||
(define ctc-gen-tests
|
||||
(test-suite
|
||||
"All random contract generation tests"
|
||||
pred-tests
|
||||
flat-ctc-tests
|
||||
func-tests))
|
||||
(check-not-exn (λ () (test-contract-generation (listof boolean?))))
|
||||
(check-not-exn (λ () (test-contract-generation (listof some-crazy-predicate?))))
|
||||
(check-not-exn (λ () (test-contract-generation (list/c boolean? number?))))
|
||||
(check-not-exn (λ () ((car (test-contract-generation (list/c (-> number? number?)))) 0)))
|
||||
|
||||
(check-exn exn:fail? (λ () ((test-contract-generation (-> char? integer?)) 0)))
|
||||
(check-not-exn (λ () ((test-contract-generation (-> integer? integer?)) 1)))
|
||||
(check-not-exn (λ () ((test-contract-generation (-> (-> integer? integer?) boolean?)) +)))
|
||||
|
||||
(run-tests ctc-gen-tests)
|
||||
(define (cannot-generate-exn? x)
|
||||
(and (exn:fail? x)
|
||||
(regexp-match #rx"contract-random-generate: unable to construct"
|
||||
(exn-message x))))
|
||||
(check-exn cannot-generate-exn? (λ () (test-contract-generation some-crazy-predicate?)))
|
||||
(check-exn cannot-generate-exn? (λ () (test-contract-generation (list/c some-crazy-predicate?))))
|
||||
|
|
|
|||
|
|
@ -10,7 +10,9 @@
|
|||
gen-arg-names
|
||||
env-item
|
||||
env-item-name
|
||||
env-item-ctc)
|
||||
env-item-ctc
|
||||
|
||||
predicate-generator-table)
|
||||
|
||||
|
||||
;; generate
|
||||
|
|
@ -28,23 +30,42 @@
|
|||
(let* ([gen (oneof (list (rand-range 0 55295)
|
||||
(rand-range 57344 1114111)))])
|
||||
(integer->char gen)))
|
||||
(define gen-hash
|
||||
|
||||
(define (integer-gen fuel)
|
||||
(* (rand-choice [1/2 1.0] [else 1])
|
||||
(rand-choice [1/2 -1] [else 1])
|
||||
(exact-nonnegative-integer-gen fuel)))
|
||||
|
||||
(define (exact-nonnegative-integer-gen fuel)
|
||||
(rand-choice
|
||||
[1/10 0]
|
||||
[1/10 1]
|
||||
[1/10 2147483647]
|
||||
[3/10 (rand-range 0 200)]
|
||||
[else (rand-range 0 2000000000)]))
|
||||
|
||||
(define (exact-positive-integer-gen fuel)
|
||||
(rand-choice
|
||||
[1/10 1]
|
||||
[1/10 2]
|
||||
[1/10 (oneof (list (expt 2 32) (expt 2 64)
|
||||
(- (expt 2 31)) (- (expt 2 63))
|
||||
(- (expt 2 31) 1) (- (expt 2 63) 1)))]
|
||||
[3/10 (rand-range 0 200)]
|
||||
[else (rand-range 0 2000000000)]))
|
||||
|
||||
(define (rational-gen fuel)
|
||||
(/ (integer-gen fuel)
|
||||
(exact-positive-integer-gen fuel)))
|
||||
|
||||
(define predicate-generator-table
|
||||
(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)]))
|
||||
integer-gen
|
||||
|
||||
exact-nonnegative-integer?
|
||||
(λ (fuel)
|
||||
(abs ((find-generate integer?) fuel)))
|
||||
exact-nonnegative-integer-gen
|
||||
|
||||
positive?
|
||||
(λ (fuel)
|
||||
|
|
@ -54,6 +75,18 @@
|
|||
[1/10 0.12]
|
||||
[1/10 2147483647]
|
||||
[else 4]))
|
||||
|
||||
rational?
|
||||
rational-gen
|
||||
|
||||
number?
|
||||
(λ (fuel)
|
||||
(rand-choice
|
||||
[1/10 (integer-gen fuel)]
|
||||
[1/10 (exact-nonnegative-integer-gen fuel)]
|
||||
[1/10 (+ (integer-gen fuel)
|
||||
(* 0+1i (integer-gen fuel)))]
|
||||
[else (rational-gen fuel)]))
|
||||
|
||||
boolean?
|
||||
(λ (fuel)
|
||||
|
|
@ -83,8 +116,7 @@
|
|||
[1/10 0]
|
||||
[1/10 1]
|
||||
[else (+ 2 (rand 260))])]
|
||||
[bstr (build-list len
|
||||
(λ (x) (rand 256)))])
|
||||
[bstr (build-list len (λ (x) (rand 256)))])
|
||||
(apply bytes bstr)))))
|
||||
|
||||
|
||||
|
|
@ -93,7 +125,7 @@
|
|||
|
||||
;; 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))
|
||||
(hash-ref predicate-generator-table func make-generate-ctc-fail))
|
||||
|
||||
(define (get-arg-names-space space-needed)
|
||||
(let ([rv (thread-cell-ref arg-names-count)])
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@
|
|||
(define (contract-random-generate ctc fuel
|
||||
[fail (λ ()
|
||||
(error 'contract-random-generate
|
||||
"Unable to construct any generator for contract: ~s"
|
||||
"unable to construct any generator for contract: ~s"
|
||||
(contract-struct-name
|
||||
(coerce-contract 'contract-random-generate ctc))))])
|
||||
(let ([def-ctc (coerce-contract 'contract-random-generate ctc)])
|
||||
|
|
|
|||
|
|
@ -699,12 +699,15 @@
|
|||
|
||||
(define (listof-generate elem-ctc)
|
||||
(λ (fuel)
|
||||
(define (mk-rand-list so-far)
|
||||
(rand-choice
|
||||
[1/5 so-far]
|
||||
[else (mk-rand-list (cons (generate/direct elem-ctc fuel)
|
||||
so-far))]))
|
||||
(mk-rand-list (list))))
|
||||
(define (mk-rand-list so-far)
|
||||
(rand-choice
|
||||
[1/5 so-far]
|
||||
[else
|
||||
(define next-elem (generate/direct elem-ctc fuel))
|
||||
(if (generate-ctc-fail? next-elem)
|
||||
(mk-rand-list so-far)
|
||||
(mk-rand-list (cons next-elem so-far)))]))
|
||||
(mk-rand-list (list))))
|
||||
|
||||
(define (listof-exercise el-ctc)
|
||||
(λ (f n-tests size env)
|
||||
|
|
@ -748,7 +751,6 @@
|
|||
#:val-first-projection (listof-*-val-first-ho-proj predicate? ctc)
|
||||
#:projection (listof-*-ho-check (λ (p v) (map p v))))]))))
|
||||
|
||||
|
||||
(define (listof-*-val-first-flat-proj predicate? ctc)
|
||||
(define vf-proj (get/build-val-first-projection ctc))
|
||||
(λ (blame)
|
||||
|
|
@ -876,6 +878,19 @@
|
|||
[v (in-list x)])
|
||||
((contract-first-order arg/c) v))))
|
||||
|
||||
(define (list/c-generate ctc)
|
||||
(define elem-ctcs (generic-list/c-args ctc))
|
||||
(λ (fuel)
|
||||
(let loop ([elem-ctcs elem-ctcs]
|
||||
[result '()])
|
||||
(cond
|
||||
[(null? elem-ctcs) (reverse result)]
|
||||
[else
|
||||
(define next-elem (generate/direct (car elem-ctcs) fuel))
|
||||
(if (generate-ctc-fail? next-elem)
|
||||
next-elem
|
||||
(loop (cdr elem-ctcs) (cons next-elem result)))]))))
|
||||
|
||||
(struct generic-list/c (args))
|
||||
|
||||
(struct flat-list/c generic-list/c ()
|
||||
|
|
@ -884,6 +899,7 @@
|
|||
(build-flat-contract-property
|
||||
#:name list/c-name-proc
|
||||
#:first-order list/c-first-order
|
||||
#:generate list/c-generate
|
||||
#:val-first-projection
|
||||
(λ (c)
|
||||
(λ (blame)
|
||||
|
|
@ -1021,6 +1037,7 @@
|
|||
(build-chaperone-contract-property
|
||||
#:name list/c-name-proc
|
||||
#:first-order list/c-first-order
|
||||
#:generate list/c-generate
|
||||
#:projection list/c-chaperone/other-projection
|
||||
#:val-first-projection list/c-chaperone/other-val-first-projection)))
|
||||
|
||||
|
|
@ -1030,6 +1047,7 @@
|
|||
(build-contract-property
|
||||
#:name list/c-name-proc
|
||||
#:first-order list/c-first-order
|
||||
#:generate list/c-generate
|
||||
#:projection list/c-chaperone/other-projection
|
||||
#:val-first-projection list/c-chaperone/other-val-first-projection))
|
||||
|
||||
|
|
|
|||
|
|
@ -43,9 +43,15 @@
|
|||
(exact? n)
|
||||
(positive? n)
|
||||
(< n 1))
|
||||
(raise-syntax-error #f "expected each option to be a real exact number in the interval (0,1)" stx (car as)))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected each option to be a real exact number in the interval (0,1)"
|
||||
stx (car as)))
|
||||
(unless (< (+ n sum) 1)
|
||||
(raise-syntax-error #f "expected the sum of the options to be less than 1" stx #f (syntax->list #'(a ...))))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected the sum of the options to be less than 1"
|
||||
stx #f (syntax->list #'(a ...))))
|
||||
(cons n (loop (+ sum n)
|
||||
(cdr as))))]))])
|
||||
(let* ([dens (map denominator ns)]
|
||||
|
|
@ -74,7 +80,7 @@
|
|||
|
||||
; oneof :: [a] -> a
|
||||
; Randomly chooses one of the values from a given list
|
||||
(define (oneof a-list)
|
||||
(define (oneof a-list)
|
||||
(list-ref a-list (random (length a-list))))
|
||||
|
||||
; fisher-yates shuffle
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user