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

improve contract-exercise so that it can take multiple arguments

Browse Source 
(and can use one to generate values that might break another)
This commit is contained in:
Robby Findler 2014-05-15 22:18:05 -05:00
parent 19e7b89886
commit 0e90d6449f
5 changed files with 106 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl
View File

@ -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.
}

27
pkgs/racket-pkgs/racket-test/tests/racket/contract-rand-test.rkt
View File

@ -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.

2
racket/collects/racket/contract/private/arrow-val-first.rkt
View File

@ -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)

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

@ -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

6
racket/collects/racket/contract/private/misc.rkt
View File

@ -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))