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

add generator for any/c and improve generator for or/c

Browse Source 
also improve test cases a little bit and minor Rackety
This commit is contained in:
Robby Findler 2014-05-07 16:09:39 -05:00
parent 7ec9cb0274
commit d812d171f9
5 changed files with 99 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2,7 +2,8 @@
(require racket/contract
racket/contract/private/generate-base
rackunit)
rackunit
(for-syntax racket/base))
;; this is expected to never have a generator.
(define (some-crazy-predicate? x) (and (number? x) (= x 11)))
@ -36,6 +37,7 @@
(check-not-exn (λ () (test-contract-generation (=/c 0))))
(check-not-exn (λ () (test-contract-generation (=/c 0.0))))
(check-not-exn (λ () (test-contract-generation (or/c boolean? boolean?))))
(check-not-exn (λ () (test-contract-generation any/c)))
(check-not-exn (λ () (test-contract-generation (listof boolean?))))
(check-not-exn (λ () (test-contract-generation (listof some-crazy-predicate?))))
@ -106,3 +108,41 @@
(-> (listof some-crazy-predicate?)
some-crazy-predicate?))))
(define (pos-exn-or-silence? val-or-exn)
(or (void? val-or-exn)
(and (string? val-or-exn)
(regexp-match #rx"blaming: pos" val-or-exn))))
(define (pos-exn? val-or-exn)
(and (string? val-or-exn)
(regexp-match #rx"blaming: pos" val-or-exn)))
(define-syntax (check-exercise stx)
(syntax-case stx ()
[(_ N pred exp)
(syntax/loc stx
(check-pred
pred
(with-handlers ([exn:fail? exn-message])
(contract-exercise exp N)
(void))))]))
;; the tests below that use pos-exn? have a
;; (vanishingly small) probability of not passing.
(check-exercise
10000
pos-exn?
(contract (-> (or/c #f some-crazy-predicate?) some-crazy-predicate?)
(λ (x) (if x 'fail 11))
'pos
'neg))
(check-exercise
10000
pos-exn?
(contract (-> (or/c #f some-crazy-predicate?) (or/c #f some-crazy-predicate?))
(λ (x) (if x 'fail 11))
'pos
'neg))

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

@ -49,17 +49,18 @@
(thunk)))
; generate : contract int -> ctc value or error
(define (contract-random-generate ctc fuel
[fail (λ ()
(error 'contract-random-generate
"unable to construct any generator for contract: ~e"
(coerce-contract 'contract-random-generate ctc)))])
(define (contract-random-generate ctc fuel [_fail #f])
(define def-ctc (coerce-contract 'contract-random-generate ctc))
(parameterize ([generate-env (make-hash)])
(let ([proc (generate/choose def-ctc fuel)])
(if proc
(proc)
(fail)))))
(define proc
(parameterize ([generate-env (make-hash)])
(generate/choose def-ctc fuel)))
(cond
[proc (proc)]
[_fail (_fail)]
[else
(error 'contract-random-generate
"unable to construct any generator for contract: ~e"
def-ctc)]))
;; generate/choose : contract? nonnegative-int -> (or/c #f (-> any/c))
; Iterates through generation methods until failure. Returns
@ -86,23 +87,6 @@
;; generate directly via the contract's built-in generator, if possible
(define (generate/direct ctc fuel) ((contract-struct-generate ctc) fuel))
; generate/direct-env :: contract nonnegative-int -> value
; Attemps to find a value with the given contract in the environment.
;; NB: this doesn't yet try to call things in the environment to generate
(define (generate/env ctc fuel)
(define env (generate-env))
(for/or ([avail-ctc (in-list (definitely-available-contracts))])
(and (contract-stronger? avail-ctc ctc)
(λ ()
(define available
(for/list ([(avail-ctc vs) (in-hash env)]
#:when (contract-stronger? avail-ctc ctc)
[v (in-list vs)])
v))
(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)]

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

@ -7,7 +7,8 @@
"blame.rkt"
"guts.rkt"
"rand.rkt"
"generate.rkt")
"generate.rkt"
"generate-base.rkt")
(provide flat-rec-contract
flat-murec-contract
@ -922,6 +923,14 @@
(define (any? x) #t)
(define any/c-neg-party-fn (λ (val) (λ (neg-party) val)))
(define (random-any/c fuel)
(rand-choice
[1/2 (oneof '(0 #f "" () #() -1 1 #t elephant))]
[else
((hash-ref predicate-generator-table
(oneof (hash-keys predicate-generator-table)))
fuel)]))
(define-struct any/c ()
#:property prop:custom-write custom-write-property-proc
#:omit-define-syntaxes
@ -931,6 +940,7 @@
#:val-first-projection (λ (ctc) (λ (blame) any/c-neg-party-fn))
#:stronger (λ (this that) (any/c? that))
#:name (λ (ctc) 'any/c)
#:generate (λ (ctc) (λ (fuel) (λ () (random-any/c fuel))))
#:first-order get-any?))
(define/final-prop any/c (make-any/c))

26
racket/collects/racket/contract/private/orc.rkt
View File

@ -132,7 +132,7 @@
(loop (cdr ho-contracts))]))))
'())))
(define ((or/c-generate ctcs) fuel)
(define ((or/c-generate or/c-ctc ctcs) fuel)
(define directs
(filter
values
@ -144,7 +144,8 @@
(can-generate/env? ctc))))
(cond
[can-generate?
(define options (append directs ctcs))
;; #f => try to use me in the env.
(define options (cons #f (append directs ctcs)))
(define env (generate-env))
(λ ()
(let loop ([options (permute options)])
@ -153,11 +154,14 @@
[else
(define option (car options))
(cond
[(not option)
(try/env
or/c-ctc env
(λ () (loop (cdr options))))]
[(contract? option)
(try/env
option env
(λ ()
(loop (cdr options))))]
(λ () (loop (cdr options))))]
[else (option)])])))]
[else #f]))
@ -176,7 +180,8 @@
#:name single-or/c-name
#:first-order single-or/c-first-order
#:stronger single-or/c-stronger?
#:generate (λ (ctc) (or/c-generate (cons (single-or/c-ho-ctc ctc)
#:generate (λ (ctc) (or/c-generate ctc
(cons (single-or/c-ho-ctc ctc)
(single-or/c-flat-ctcs ctc))))
#:exercise (λ (ctc) (or/c-exercise (list (single-or/c-ho-ctc ctc)))))))
@ -189,7 +194,8 @@
#:name single-or/c-name
#:first-order single-or/c-first-order
#:stronger single-or/c-stronger?
#:generate (λ (ctc) (or/c-generate (cons (single-or/c-ho-ctc ctc)
#:generate (λ (ctc) (or/c-generate ctc
(cons (single-or/c-ho-ctc ctc)
(single-or/c-flat-ctcs ctc))))
#:exercise (λ (ctc) (or/c-exercise (list (single-or/c-ho-ctc ctc))))))
@ -325,7 +331,8 @@
#:name multi-or/c-name
#:first-order multi-or/c-first-order
#:stronger multi-or/c-stronger?
#:generate (λ (ctc) (or/c-generate (append (multi-or/c-ho-ctcs ctc)
#:generate (λ (ctc) (or/c-generate ctc
(append (multi-or/c-ho-ctcs ctc)
(multi-or/c-flat-ctcs ctc))))
#:exercise (λ (ctc) (or/c-exercise (multi-or/c-ho-ctcs ctc))))))
@ -338,7 +345,8 @@
#:name multi-or/c-name
#:first-order multi-or/c-first-order
#:stronger multi-or/c-stronger?
#:generate (λ (ctc) (or/c-generate (append (multi-or/c-ho-ctcs ctc)
#:generate (λ (ctc) (or/c-generate ctc
(append (multi-or/c-ho-ctcs ctc)
(multi-or/c-flat-ctcs ctc))))
#:exercise (λ (ctc) (or/c-exercise (multi-or/c-ho-ctcs ctc)))))
@ -385,7 +393,7 @@
#:first-order
(λ (ctc) (flat-or/c-pred ctc))
#:generate (λ (ctc) (or/c-generate (flat-or/c-flat-ctcs ctc)))))
#:generate (λ (ctc) (or/c-generate ctc (flat-or/c-flat-ctcs ctc)))))

23
racket/collects/racket/contract/private/struct-dc.rkt
View File

@ -25,7 +25,8 @@
"blame.rkt"
"prop.rkt"
"misc.rkt"
"opt.rkt")
"opt.rkt"
"generate.rkt")
;; these are the runtime structs for struct/dc.
;; each struct/dc contract has a list of subcontract's attached
@ -633,6 +634,17 @@
(define-struct base-struct/dc (subcontracts pred struct-name here name-info struct/c?))
(define (struct/dc-exercise stct)
(λ (fuel)
(define env (generate-env))
(values
(λ (val)
;; need to extract the fields and do it in
;; the right order to figure out the contracts
;; and then throw them into the environment
(void))
(map indep-ctc (filter indep? (base-struct/dc-subcontracts stct))))))
(define-struct (struct/dc base-struct/dc) ()
#:property prop:chaperone-contract
(parameterize ([skip-projection-wrapper? #t])
@ -640,7 +652,8 @@
#:name struct/dc-name
#:first-order struct/dc-first-order
#:projection struct/dc-proj
#:stronger struct/dc-stronger?)))
#:stronger struct/dc-stronger?
#:exercise struct/dc-exercise)))
(define-struct (flat-struct/dc base-struct/dc) ()
#:property prop:flat-contract
@ -649,7 +662,8 @@
#:name struct/dc-name
#:first-order struct/dc-flat-first-order
#:projection struct/dc-proj
#:stronger struct/dc-stronger?)))
#:stronger struct/dc-stronger?
#:exercise struct/dc-exercise)))
(define-struct (impersonator-struct/dc base-struct/dc) ()
#:property prop:contract
@ -658,7 +672,8 @@
#:name struct/dc-name
#:first-order struct/dc-first-order
#:projection struct/dc-proj
#:stronger struct/dc-stronger?)))
#:stronger struct/dc-stronger?
#:exercise struct/dc-exercise)))
(define (build-struct/dc subcontracts pred struct-name here name-info struct/c?)
(for ([subcontract (in-list subcontracts)])