From 0e90d6449fe7c2d31e1a95a4788e07a1ab215387 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 15 May 2014 22:18:05 -0500 Subject: [PATCH] improve contract-exercise so that it can take multiple arguments (and can use one to generate values that might break another) --- .../scribblings/reference/contracts.scrbl | 12 +-- .../tests/racket/contract-rand-test.rkt | 27 ++++++- .../contract/private/arrow-val-first.rkt | 2 +- .../racket/contract/private/generate.rkt | 77 ++++++++++++++++--- .../collects/racket/contract/private/misc.rkt | 6 ++ 5 files changed, 106 insertions(+), 18 deletions(-) diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl index 3dd64f231c..f3b1356890 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl @@ -2779,11 +2779,11 @@ generators) or because there is not enough fuel. In either case, the thunk @racket[fail] is invoked. } -@defproc[(contract-exercise [val any/c]) void?]{ - Attempts to get @racket[val] to break its contract (if any). +@defproc[(contract-exercise [val any/c] ...+) void?]{ + Attempts to get the @racket[val]s to break their contracts (if any). - Uses @racket[value-contract] to determine if @racket[val] has a contract and, - if it does, uses information about the contract's shape to poke and prod - at the value. For example, if the value is function, it will use the contract - to tell it what arguments to supply to the value. + Uses @racket[value-contract] to determine if any of the @racket[val]s have a + contract and, for those that do, uses information about the contract's shape + to poke and prod at the value. For example, if the value is function, it will + use the contract to tell it what arguments to supply to the value. } 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 224664a9d7..836cd1b977 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 @@ -159,14 +159,37 @@ (define-syntax (check-exercise stx) (syntax-case stx () - [(_ N pred exp) + [(_ N pred . exps) (syntax/loc stx (check-pred pred (with-handlers ([exn:fail? exn-message]) - (contract-exercise exp N) + (contract-exercise #:fuel N . exps) (void))))])) +(check-exercise + 1 + pos-exn? + (contract (-> some-crazy-predicate? string?) + (λ (x) 'not-a-string) + 'pos + 'neg) + (contract (-> some-crazy-predicate?) + (λ () 11) + 'wrong-one + 'wrong-two)) + +(check-exercise + 1 + pos-exn? + (contract (-> some-crazy-predicate?) + (λ () 11) + 'wrong-one + 'wrong-two) + (contract (-> some-crazy-predicate? string?) + (λ (x) 'not-a-string) + 'pos + 'neg)) ;; the tests below that use pos-exn? have a ;; (vanishingly small) probability of not passing. diff --git a/racket/collects/racket/contract/private/arrow-val-first.rkt b/racket/collects/racket/contract/private/arrow-val-first.rkt index cb98116140..54bd63c761 100644 --- a/racket/collects/racket/contract/private/arrow-val-first.rkt +++ b/racket/collects/racket/contract/private/arrow-val-first.rkt @@ -762,7 +762,7 @@ (λ (fuel) (define gens (for/list ([dom-ctc (in-list dom-ctcs)]) - ((contract-struct-generate dom-ctc) fuel))) + (generate/choose dom-ctc fuel))) (define env (generate-env)) (cond [(andmap values gens) diff --git a/racket/collects/racket/contract/private/generate.rkt b/racket/collects/racket/contract/private/generate.rkt index 39bf26d3ca..c52b208abe 100644 --- a/racket/collects/racket/contract/private/generate.rkt +++ b/racket/collects/racket/contract/private/generate.rkt @@ -16,16 +16,75 @@ generate-ctc-fail? with-definitely-available-contracts can-generate/env? - try/env) + try/env + multi-exercise) -(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)))) +(define (contract-exercise #:fuel [fuel 10] v1 . vs) + (define vals + (for/list ([val (in-list (cons v1 vs))] + #:when (value-contract val)) + val)) + (define ctcs (map value-contract vals)) + (define-values (go _) + (parameterize ([generate-env (make-hash)]) + ((multi-exercise ctcs) fuel))) + (for ([x (in-range fuel)]) + (go vals))) + +;; multi-exercise : (listof contract?) -> fuel -> (values (listof ctc) (-> (listof val[ctcs]) void) +(define (multi-exercise orig-ctcs) + (λ (fuel) + (let loop ([ctcs orig-ctcs] + [exers '()] + [previously-available-ctcs '()] + [available-ctcs '()] + [max-iterations 4]) + (cond + [(null? ctcs) + (cond + [(or (zero? max-iterations) + (equal? previously-available-ctcs available-ctcs)) + (define rev-exers (reverse exers)) + (values (λ (orig-vals) + (let loop ([exers rev-exers] + [vals orig-vals]) + (cond + [(null? exers) (void)] + [(null? vals) (loop exers orig-vals)] + [else + ((car exers) (car vals)) + (loop (cdr exers) (cdr vals))]))) + available-ctcs)] + [else + (loop orig-ctcs + exers + available-ctcs + available-ctcs + (- max-iterations 1))])] + [else + (define-values (exer newly-available-ctcs) + (with-definitely-available-contracts + available-ctcs + (λ () + ((contract-struct-exercise (car ctcs)) fuel)))) + (loop (cdr ctcs) + (cons exer exers) + previously-available-ctcs + (add-new-contracts newly-available-ctcs available-ctcs) + max-iterations)])))) + +(define (add-new-contracts newly-available-ctcs available-ctcs) + (let loop ([available-ctcs available-ctcs] + [newly-available-ctcs newly-available-ctcs]) + (cond + [(null? newly-available-ctcs) available-ctcs] + [else + (if (member (car newly-available-ctcs) available-ctcs) + (loop available-ctcs + (cdr newly-available-ctcs)) + (loop (cons (car newly-available-ctcs) available-ctcs) + (cdr newly-available-ctcs)))]))) + ;; a stash of values and the contracts that they correspond to ;; that generation has produced earlier in the process diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt index d720caab68..3fe99169aa 100644 --- a/racket/collects/racket/contract/private/misc.rkt +++ b/racket/collects/racket/contract/private/misc.rkt @@ -631,6 +631,9 @@ [else #f]))) +(define (list/c-exercise ctc) + (multi-exercise (generic-list/c-args ctc))) + (struct generic-list/c (args)) (struct flat-list/c generic-list/c () @@ -640,6 +643,7 @@ #:name list/c-name-proc #:first-order list/c-first-order #:generate list/c-generate + #:exercise list/c-exercise #:val-first-projection (λ (c) (λ (blame) @@ -778,6 +782,7 @@ #:name list/c-name-proc #:first-order list/c-first-order #:generate list/c-generate + #:exercise list/c-exercise #:projection list/c-chaperone/other-projection #:val-first-projection list/c-chaperone/other-val-first-projection))) @@ -788,6 +793,7 @@ #:name list/c-name-proc #:first-order list/c-first-order #:generate list/c-generate + #:exercise list/c-exercise #:projection list/c-chaperone/other-projection #:val-first-projection list/c-chaperone/other-val-first-projection))