From 1cb1ff284b1c94978a07d407064ab8262256c5a1 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 17 Apr 2014 16:14:04 -0500 Subject: [PATCH] some work on random generation from contracts --- .../tests/racket/contract-rand-test.rkt | 76 ++++++++----------- .../racket/contract/private/generate-base.rkt | 64 ++++++++++++---- .../racket/contract/private/generate.rkt | 2 +- .../collects/racket/contract/private/misc.rkt | 32 ++++++-- .../collects/racket/contract/private/rand.rkt | 12 ++- 5 files changed, 113 insertions(+), 73 deletions(-) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract-rand-test.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract-rand-test.rkt index fcd7e0f9fc..9531a953a3 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/contract-rand-test.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract-rand-test.rkt @@ -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 ( 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 ( 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?)))) diff --git a/racket/collects/racket/contract/private/generate-base.rkt b/racket/collects/racket/contract/private/generate-base.rkt index 00e389dcd6..046f0ca87e 100644 --- a/racket/collects/racket/contract/private/generate-base.rkt +++ b/racket/collects/racket/contract/private/generate-base.rkt @@ -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)]) diff --git a/racket/collects/racket/contract/private/generate.rkt b/racket/collects/racket/contract/private/generate.rkt index 5f5c34b52c..4126cf269a 100644 --- a/racket/collects/racket/contract/private/generate.rkt +++ b/racket/collects/racket/contract/private/generate.rkt @@ -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)]) diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt index 668b5c128e..ac15d23e75 100644 --- a/racket/collects/racket/contract/private/misc.rkt +++ b/racket/collects/racket/contract/private/misc.rkt @@ -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)) diff --git a/racket/collects/racket/contract/private/rand.rkt b/racket/collects/racket/contract/private/rand.rkt index b852cf762e..bb458d79ab 100644 --- a/racket/collects/racket/contract/private/rand.rkt +++ b/racket/collects/racket/contract/private/rand.rkt @@ -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