From 0f16f31db9deac4026675f45b257bb5c9725f3bf Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 6 May 2014 21:25:34 -0500 Subject: [PATCH] clean up and export support for exercising values with contracts --- racket/collects/racket/contract.rkt | 3 +- .../contract/private/arrow-val-first.rkt | 22 --------- .../racket/contract/private/generate.rkt | 46 ++++++++++++++++--- .../collects/racket/contract/private/orc.rkt | 41 +++++++++++------ 4 files changed, 69 insertions(+), 43 deletions(-) diff --git a/racket/collects/racket/contract.rkt b/racket/collects/racket/contract.rkt index f91ec53e04..2e9ebf5498 100644 --- a/racket/collects/racket/contract.rkt +++ b/racket/collects/racket/contract.rkt @@ -12,4 +12,5 @@ "contract/region.rkt" "contract/private/legacy.rkt" "contract/private/ds.rkt") - contract-random-generate) + contract-random-generate + contract-exercise) diff --git a/racket/collects/racket/contract/private/arrow-val-first.rkt b/racket/collects/racket/contract/private/arrow-val-first.rkt index 3ce11ff322..cb98116140 100644 --- a/racket/collects/racket/contract/private/arrow-val-first.rkt +++ b/racket/collects/racket/contract/private/arrow-val-first.rkt @@ -784,28 +784,6 @@ [else (λ (fuel) (values void '()))])) -#| - - (λ (v) - (let* ([new-fuel (/ fuel 2)] - [gen-if-fun (λ (c v) - ; If v is a function we need to gen the domain and call - (if (procedure? v) - (let ([newargs (map (λ (c) (contract-random-generate c new-fuel)) - (base->-doms c))]) - (let* ([result (call-with-values - (λ () (apply v newargs)) - list)] - [rngs (base->-rngs c)]) - (andmap (λ (c v) - ((contract-struct-exercise c) v new-fuel)) - rngs - result))) - ; Delegate to check-ctc-val - ((contract-struct-exercise c) v new-fuel)))]) - (andmap gen-if-fun (base->-doms ctc) args)))))] -|# - (define (base->-name ctc) (define rngs (base->-rngs ctc)) (define rng-sexp diff --git a/racket/collects/racket/contract/private/generate.rkt b/racket/collects/racket/contract/private/generate.rkt index 53c1273b7d..0a03a113df 100644 --- a/racket/collects/racket/contract/private/generate.rkt +++ b/racket/collects/racket/contract/private/generate.rkt @@ -9,11 +9,23 @@ (provide generate-env env-stash contract-random-generate + contract-exercise generate/direct generate/choose make-generate-ctc-fail generate-ctc-fail? - with-definitely-available-contracts) + with-definitely-available-contracts + can-generate/env? + try/env) + +(define (contract-exercise v [fuel 10]) + (define ctc (value-contract v)) + (when ctc + (define-values (go ctcs) + (parameterize ([generate-env (make-hash)]) + ((contract-struct-exercise ctc) fuel))) + (for ([x (in-range fuel)]) + (go v)))) ;; a stash of values and the contracts that they correspond to ;; that generation has produced earlier in the process @@ -54,15 +66,21 @@ ; #f if no value could be generated (define (generate/choose ctc fuel) (define direct (generate/direct ctc fuel)) - (define env (generate/env ctc fuel)) + (define env-can? (can-generate/env? ctc)) + (define env (generate-env)) (cond - [(and direct env) + [direct (λ () - (if (zero? (rand 2)) + (define use-direct? (zero? (rand 2))) + (if use-direct? (direct) - (env)))] - [else - (or direct env)])) + (try/env ctc env direct)))] + [env-can? + (λ () + (try/env + ctc env + (λ () (error 'generate/choose "internal generation failure"))))] + [else #f])) ; generate/direct :: contract nonnegative-int -> (or/c #f (-> val)) ;; generate directly via the contract's built-in generator, if possible @@ -84,3 +102,17 @@ (when (null? available) (error 'generate.rkt "internal error: no values satisfying ~s available" ctc)) (oneof available))))) + +(define (try/env ctc env fail) + (define available + (for/list ([(avail-ctc vs) (in-hash env)] + #:when (contract-stronger? avail-ctc ctc) + [v (in-list vs)]) + v)) + (cond + [(null? available) (fail)] + [else (oneof available)])) + +(define (can-generate/env? ctc) + (for/or ([avail-ctc (in-list (definitely-available-contracts))]) + (contract-stronger? avail-ctc ctc))) diff --git a/racket/collects/racket/contract/private/orc.rkt b/racket/collects/racket/contract/private/orc.rkt index 00814c100d..f5376a3dba 100644 --- a/racket/collects/racket/contract/private/orc.rkt +++ b/racket/collects/racket/contract/private/orc.rkt @@ -132,18 +132,33 @@ (loop (cdr ho-contracts))])))) '()))) -(define (or/c-generate ctcs) - (λ (fuel) - (define choices - (filter - values - (for/list ([ctc (in-list ctcs)]) - (generate/choose ctc fuel)))) - (cond - [(null? choices) #f] - [else - (lambda () - ((oneof choices)))]))) +(define ((or/c-generate ctcs) fuel) + (define directs + (filter + values + (for/list ([ctc (in-list ctcs)]) + (generate/direct ctc fuel)))) + (define can-generate? + (or (pair? directs) + (for/or ([ctc (in-list ctcs)]) + (can-generate/env? ctc)))) + (cond + [can-generate? + (define options (append directs ctcs)) + (define env (generate-env)) + (λ () + (let loop ([options (permute options)]) + (cond + [(null? options) (error 'or/c-generate "shouldn't fail!")] + [else + (define option (car options)) + (cond + [(contract? option) + (try/env + option env + (λ () + (loop (cdr options))))] + [else (option)])])))])) (define-struct single-or/c (name pred flat-ctcs ho-ctc) #:property prop:orc-contract @@ -406,4 +421,4 @@ (λ (x) (or (char? x) (symbol? x) (boolean? x) (null? x) (keyword? x) (number? x) - (void? x)))) \ No newline at end of file + (void? x))))