Started on random testing for contracts
This commit is contained in:
parent
37a7e0a2e1
commit
b8847a53bf
|
@ -5,10 +5,12 @@
|
|||
"contract/region.rkt"
|
||||
"contract/private/basic-opters.rkt"
|
||||
"contract/private/legacy.rkt"
|
||||
"contract/private/ds.rkt")
|
||||
"contract/private/ds.rkt"
|
||||
"contract/private/generate.rkt")
|
||||
(provide (all-from-out "contract/base.rkt"
|
||||
"contract/combinator.rkt"
|
||||
"contract/parametric.rkt"
|
||||
"contract/region.rkt"
|
||||
"contract/private/legacy.rkt"
|
||||
"contract/private/ds.rkt"))
|
||||
"contract/private/ds.rkt"
|
||||
"contract/private/generate.rkt"))
|
||||
|
|
|
@ -20,8 +20,7 @@
|
|||
procedure-accepts-and-more?
|
||||
check-procedure
|
||||
check-procedure/more
|
||||
make-contracted-function
|
||||
|
||||
|
||||
contracted-function?
|
||||
contracted-function-proc
|
||||
contracted-function-ctc
|
||||
|
|
|
@ -18,10 +18,12 @@ v4 todo:
|
|||
|
||||
|#
|
||||
|
||||
|
||||
(require "guts.rkt"
|
||||
"blame.rkt"
|
||||
"prop.rkt"
|
||||
"misc.rkt"
|
||||
"generate.rkt"
|
||||
racket/stxparam)
|
||||
(require (for-syntax racket/base)
|
||||
(for-syntax "helpers.rkt")
|
||||
|
@ -30,9 +32,12 @@ v4 todo:
|
|||
(for-syntax "arr-util.rkt"))
|
||||
|
||||
(provide ->
|
||||
base->?
|
||||
->*
|
||||
->d
|
||||
case->
|
||||
base->-rngs/c
|
||||
base->-doms/c
|
||||
unconstrained-domain->
|
||||
the-unsupplied-arg
|
||||
(rename-out [-predicate/c predicate/c])
|
||||
|
@ -520,13 +525,54 @@ v4 todo:
|
|||
(= (length (base->-rngs/c that)) (length (base->-rngs/c this)))
|
||||
(andmap contract-stronger? (base->-rngs/c this) (base->-rngs/c that))))
|
||||
|
||||
(define (->-generate ctc)
|
||||
(let ([doms-l (length (base->-doms/c ctc))])
|
||||
(λ (fuel)
|
||||
(let ([rngs-gens (map (λ (c) (generate/choose c (/ fuel 2)))
|
||||
(base->-rngs/c ctc))])
|
||||
(if (member #t (map generate-ctc-fail? rngs-gens))
|
||||
(make-generate-ctc-fail)
|
||||
(procedure-reduce-arity
|
||||
(λ args
|
||||
; Make sure that the args match the contract
|
||||
(begin (unless ((contract-struct-exercise ctc) args (/ fuel 2))
|
||||
(error "Arg(s) ~a do(es) not match contract ~a\n" ctc))
|
||||
; Stash the valid value
|
||||
;(env-stash (generate-env) ctc args)
|
||||
(apply values rngs-gens)))
|
||||
doms-l))))))
|
||||
|
||||
(define (->-exercise ctc)
|
||||
(λ (args fuel)
|
||||
(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-generate c new-fuel))
|
||||
(base->-doms/c c))])
|
||||
(let* ([result (call-with-values
|
||||
(λ () (apply v newargs))
|
||||
list)]
|
||||
[rngs (base->-rngs/c 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/c ctc) args))))
|
||||
|
||||
|
||||
|
||||
(define-struct (chaperone-> base->) ()
|
||||
#:property prop:chaperone-contract
|
||||
(build-chaperone-contract-property
|
||||
#:projection (->-proj chaperone-procedure)
|
||||
#:name ->-name
|
||||
#:first-order ->-first-order
|
||||
#:stronger ->-stronger?))
|
||||
#:stronger ->-stronger?
|
||||
#:generate ->-generate
|
||||
#:exercise ->-exercise))
|
||||
|
||||
(define-struct (impersonator-> base->) ()
|
||||
#:property prop:contract
|
||||
|
@ -534,7 +580,9 @@ v4 todo:
|
|||
#:projection (->-proj impersonate-procedure)
|
||||
#:name ->-name
|
||||
#:first-order ->-first-order
|
||||
#:stronger ->-stronger?))
|
||||
#:stronger ->-stronger?
|
||||
#:generate ->-generate
|
||||
#:exercise ->-exercise))
|
||||
|
||||
(define (build--> name
|
||||
pre post
|
||||
|
@ -659,9 +707,9 @@ v4 todo:
|
|||
#f))]))))]))
|
||||
|
||||
(define-for-syntax (maybe-a-method/name stx)
|
||||
(if (syntax-parameter-value #'making-a-method)
|
||||
(syntax-property stx 'method-arity-error #t)
|
||||
stx))
|
||||
(if (syntax-parameter-value #'making-a-method)
|
||||
(syntax-property stx 'method-arity-error #t)
|
||||
stx))
|
||||
|
||||
;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
|
||||
(define-for-syntax (->/proc/main stx)
|
||||
|
|
26
collects/racket/contract/private/env.rkt
Normal file
26
collects/racket/contract/private/env.rkt
Normal file
|
@ -0,0 +1,26 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "arrow.rkt"
|
||||
"guts.rkt")
|
||||
(provide
|
||||
build-env)
|
||||
|
||||
(define (make-env)
|
||||
(list))
|
||||
|
||||
(define (extend-env ctc exp env)
|
||||
(cons (list ctc exp)
|
||||
env))
|
||||
|
||||
(define (build-env f-l)
|
||||
(let ([value-contract (dynamic-require 'racket/contract 'value-contract)]
|
||||
; [->-rngs/c (dynamic-require 'racket/contract/private/arrow '->-rngs/c)]
|
||||
; [contract-stronger? (dynamic-require 'racket/contract 'contract-stronger?)]
|
||||
[env-item (dynamic-require 'racket/contract/private/generator-base 'env-item)]
|
||||
; [->-rngs/c (dynamic-require 'racket/contract/private/arrow '->-rngs/c)]
|
||||
)
|
||||
(map (λ (f)
|
||||
(env-item (value-contract f)
|
||||
f))
|
||||
f-l))
|
||||
)
|
82
collects/racket/contract/private/generate-base.rkt
Normal file
82
collects/racket/contract/private/generate-base.rkt
Normal file
|
@ -0,0 +1,82 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide
|
||||
make-generate-ctc-fail
|
||||
generate-ctc-fail?
|
||||
find-generate
|
||||
add-generate
|
||||
|
||||
print-freq
|
||||
get-freq
|
||||
merge-freq
|
||||
count-missing-generate
|
||||
|
||||
get-arg-names-space
|
||||
gen-arg-names
|
||||
env-item
|
||||
env-item-name
|
||||
env-item-ctc)
|
||||
|
||||
|
||||
;; generate
|
||||
(define-struct env-item (ctc name))
|
||||
|
||||
;; generate failure type
|
||||
(define-struct generate-ctc-fail ())
|
||||
|
||||
;; hash tables
|
||||
(define freq-hash (make-hash))
|
||||
(define gen-hash (make-hash))
|
||||
|
||||
;; thread-cell
|
||||
(define arg-names-count (make-thread-cell 0))
|
||||
|
||||
;; 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)))
|
||||
|
||||
(define (add-generate ctc gen)
|
||||
(hash-set! gen-hash ctc gen))
|
||||
|
||||
|
||||
(define (get-arg-names-space space-needed)
|
||||
(let ([rv (thread-cell-ref arg-names-count)])
|
||||
(thread-cell-set! arg-names-count (+ rv space-needed))
|
||||
rv))
|
||||
|
||||
(define (gen-arg-names st-num size)
|
||||
(cond
|
||||
[(<= size 0) (list)]
|
||||
[else (cons (string->symbol (string-append "x-" (number->string st-num)))
|
||||
(gen-arg-names (+ st-num 1) (- size 1)))]))
|
||||
|
||||
(define (print-freq)
|
||||
(let* ([l (hash-map freq-hash (λ (k v)
|
||||
(list k v)))]
|
||||
[l-s (sort l (λ (e1 e2)
|
||||
(> (list-ref e1 1)
|
||||
(list-ref e2 1))))])
|
||||
(map (λ (x)
|
||||
(printf "# ~a : ~a\n"
|
||||
(list-ref x 1)
|
||||
(list-ref x 0)))
|
||||
l-s))
|
||||
null)
|
||||
|
||||
(define (count-missing-generate ctc)
|
||||
(hash-update! freq-hash
|
||||
ctc
|
||||
(λ (x)
|
||||
(+ x 1))
|
||||
0))
|
||||
|
||||
|
||||
|
||||
(define (get-freq)
|
||||
freq-hash)
|
||||
|
||||
(define (merge-freq h)
|
||||
(hash-for-each h (λ (k v)
|
||||
(hash-set! freq-hash k (+ (hash-ref freq-hash k 0)
|
||||
v)))))
|
||||
|
164
collects/racket/contract/private/generate.rkt
Normal file
164
collects/racket/contract/private/generate.rkt
Normal file
|
@ -0,0 +1,164 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "rand.rkt"
|
||||
"generate-base.rkt"
|
||||
"guts.rkt"
|
||||
"prop.rkt"
|
||||
racket/list)
|
||||
|
||||
(provide generate-env
|
||||
env-stash
|
||||
|
||||
contract-generate
|
||||
|
||||
generate/direct
|
||||
generate/choose
|
||||
|
||||
make-generate-ctc-fail
|
||||
generate-ctc-fail?)
|
||||
|
||||
; env parameter
|
||||
(define generate-env (make-parameter #f))
|
||||
|
||||
; Adds a new contract and value to the environment if
|
||||
; they don't already exist
|
||||
(define (env-stash env ctc val)
|
||||
(let* ([curvals (hash-ref env ctc (list))])
|
||||
(hash-set! env ctc (cons val curvals))))
|
||||
|
||||
;; hash tables
|
||||
;(define freq-hash (make-hash))
|
||||
;(define gen-hash (make-hash))
|
||||
|
||||
;; thread-cell
|
||||
;(define arg-names-count (make-thread-cell 0))
|
||||
|
||||
;; generate integer?
|
||||
(add-generate 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)])))
|
||||
|
||||
(add-generate exact-nonnegative-integer?
|
||||
(λ (fuel)
|
||||
(abs ((find-generate integer?) fuel))))
|
||||
|
||||
|
||||
(add-generate positive?
|
||||
(λ (fuel)
|
||||
(rand-choice
|
||||
[1/10 1]
|
||||
[1/10 1/3]
|
||||
[1/10 0.12]
|
||||
[1/10 2147483647]
|
||||
[else 4])))
|
||||
|
||||
(add-generate boolean?
|
||||
(λ (fuel)
|
||||
(rand-choice
|
||||
[1/2 #t]
|
||||
[else #f])))
|
||||
|
||||
(add-generate char?
|
||||
(λ (fuel)
|
||||
(let* ([gen (oneof (list (rand-range 0 55295)
|
||||
(rand-range 57344 1114111)))])
|
||||
(integer->char gen))))
|
||||
|
||||
(add-generate string?
|
||||
(λ (fuel)
|
||||
(let* ([len (rand-choice [1/10 0]
|
||||
[1/10 1]
|
||||
[else (rand-range 2 260)])]
|
||||
[strl (build-list len
|
||||
(λ (x)
|
||||
(gen-pred/direct char? fuel)))])
|
||||
(apply string strl))))
|
||||
|
||||
(add-generate byte?
|
||||
(λ (fuel)
|
||||
(rand 256)))
|
||||
|
||||
(add-generate bytes?
|
||||
(λ (fuel)
|
||||
(let* ([len (rand-choice
|
||||
[1/10 0]
|
||||
[1/10 1]
|
||||
[else (+ 2 (rand 260))])]
|
||||
[bstr (build-list len
|
||||
(λ (x)
|
||||
(rand 256)))])
|
||||
(apply bytes bstr))))
|
||||
|
||||
(define (gen-pred/direct pred fuel)
|
||||
(let ([ctc (coerce-contract 'contract-direct-gen pred)])
|
||||
(generate/direct ctc fuel)))
|
||||
|
||||
; generate : contract int -> ctc value or error
|
||||
(define (contract-generate ctc fuel)
|
||||
(let ([def-ctc (coerce-contract 'contract-generate ctc)])
|
||||
(parameterize ([generate-env (make-hash)])
|
||||
; choose randomly
|
||||
(let ([val (generate/choose def-ctc fuel)])
|
||||
(if (generate-ctc-fail? val)
|
||||
(error 'contract-generate
|
||||
"Unable to construct any generator for contract: ~e"
|
||||
ctc)
|
||||
val)))))
|
||||
|
||||
; Iterates through generation methods until failure. Returns
|
||||
; generate-ctc-fail if no value could be generated
|
||||
(define (generate/choose ctc fuel)
|
||||
(let ([options (permute (list generate/direct
|
||||
generate/direct-env
|
||||
))])
|
||||
; choose randomly
|
||||
(let trygen ([options options])
|
||||
(if (empty? options)
|
||||
(make-generate-ctc-fail)
|
||||
(let* ([option (car options)]
|
||||
[val (option ctc fuel)])
|
||||
(if (generate-ctc-fail? val)
|
||||
(trygen (cdr options))
|
||||
val))))))
|
||||
|
||||
; generate/direct :: contract int -> value for contract
|
||||
; Attempts to make a generator that generates values for this contract
|
||||
; directly. Returns generate-ctc-fail if making a generator fails.
|
||||
(define (generate/direct ctc fuel)
|
||||
(let ([g (contract-struct-generate ctc)])
|
||||
; Check if the contract has a direct generate attached
|
||||
(if (generate-ctc-fail? g)
|
||||
; Everything failed -- we can't directly generate this ctc
|
||||
g
|
||||
(g fuel))))
|
||||
|
||||
; generate/direct-env :: contract int -> value
|
||||
; Attemps to find a value with the given contract in the environment.
|
||||
; Returns it if found and generate-ctc-fail otherwise.
|
||||
(define (generate/direct-env ctc fuel)
|
||||
; TODO: find out how to make negative test cases
|
||||
(let* ([keys (hash-keys (generate-env))]
|
||||
[valid-ctcs (filter (λ (c)
|
||||
(contract-stronger? c ctc))
|
||||
keys)])
|
||||
(if (> (length valid-ctcs) 0)
|
||||
(oneof (oneof (map (λ (key)
|
||||
(hash-ref (generate-env) key))
|
||||
valid-ctcs)))
|
||||
(make-generate-ctc-fail))))
|
||||
|
||||
; generate/indirect-env :: contract int -> (int -> value for contract)
|
||||
; Attempts to make a generator that generates values for this contract
|
||||
; by calling functions in the environment
|
||||
(define (generate/indirect-env ctc fuel)
|
||||
(if (> fuel 0)
|
||||
(make-generate-ctc-fail)
|
||||
(make-generate-ctc-fail)))
|
||||
|
|
@ -1,6 +1,11 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "prop.rkt")
|
||||
(require "helpers.rkt"
|
||||
"blame.rkt"
|
||||
"prop.rkt"
|
||||
"rand.rkt"
|
||||
"generate-base.rkt"
|
||||
racket/pretty)
|
||||
|
||||
(require (for-syntax racket/base))
|
||||
|
||||
|
@ -148,7 +153,7 @@
|
|||
(cond
|
||||
[(contract-struct? x) x]
|
||||
[(and (procedure? x) (procedure-arity-includes? x 1))
|
||||
(make-predicate-contract (or (object-name x) '???) x)]
|
||||
(make-predicate-contract (or (object-name x) '???) x (make-generate-ctc-fail))]
|
||||
[(or (symbol? x) (boolean? x) (char? x) (null? x)) (make-eq-contract x)]
|
||||
[(or (bytes? x) (string? x)) (make-equal-contract x)]
|
||||
[(number? x) (make-=-contract x)]
|
||||
|
@ -237,10 +242,6 @@
|
|||
(if (contract-struct? sub) (contract-struct-name sub) sub)))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
;
|
||||
|
@ -308,7 +309,7 @@
|
|||
(and (regexp/c? that) (eq? (regexp/c-reg this) (regexp/c-reg that))))))
|
||||
|
||||
|
||||
(define-struct predicate-contract (name pred)
|
||||
(define-struct predicate-contract (name pred generate)
|
||||
#:property prop:flat-contract
|
||||
(build-flat-contract-property
|
||||
#:stronger
|
||||
|
@ -317,7 +318,18 @@
|
|||
(procedure-closure-contents-eq? (predicate-contract-pred this)
|
||||
(predicate-contract-pred that))))
|
||||
#:name (λ (ctc) (predicate-contract-name ctc))
|
||||
#:first-order (λ (ctc) (predicate-contract-pred ctc))))
|
||||
#:first-order (λ (ctc) (predicate-contract-pred ctc))
|
||||
#:generate (λ (ctc)
|
||||
(let ([generate (predicate-contract-generate ctc)])
|
||||
(if (generate-ctc-fail? generate)
|
||||
(let ([fn (predicate-contract-pred ctc)])
|
||||
(find-generate fn (predicate-contract-name ctc)))
|
||||
generate)))
|
||||
#:exercise (λ (ctc)
|
||||
(λ (val fuel)
|
||||
((predicate-contract-pred ctc) val)))))
|
||||
|
||||
(define (check-flat-named-contract predicate) (coerce-flat-contract 'flat-named-contract predicate))
|
||||
(define (check-flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
|
||||
(define (build-flat-contract name pred [generate (make-generate-ctc-fail)])
|
||||
(make-predicate-contract name pred generate))
|
||||
|
|
|
@ -4,7 +4,9 @@
|
|||
racket/promise
|
||||
"prop.rkt"
|
||||
"blame.rkt"
|
||||
"guts.rkt")
|
||||
"guts.rkt"
|
||||
"rand.rkt"
|
||||
"generate.rkt")
|
||||
|
||||
(provide flat-rec-contract
|
||||
flat-murec-contract
|
||||
|
@ -295,7 +297,12 @@
|
|||
that-ctcs)))))
|
||||
|
||||
#:first-order
|
||||
(λ (ctc) (flat-or/c-pred ctc))))
|
||||
(λ (ctc) (flat-or/c-pred ctc))
|
||||
#:generate
|
||||
(λ (ctc)
|
||||
(λ (fuel)
|
||||
(generate/direct (oneof (flat-or/c-flat-ctcs ctc)) fuel)))
|
||||
))
|
||||
|
||||
|
||||
(define (and-name ctc)
|
||||
|
@ -482,7 +489,20 @@
|
|||
[m (between/c-high ctc)])
|
||||
(λ (x)
|
||||
(and (real? x)
|
||||
(<= n x m)))))))
|
||||
(<= n x m)))))
|
||||
#:generate
|
||||
(λ (ctc)
|
||||
(λ (fuel)
|
||||
(let* ([max-n 2147483647]
|
||||
[min-n -2147483648]
|
||||
[upper (if (> (between/c-high ctc) max-n)
|
||||
max-n
|
||||
(between/c-high ctc))]
|
||||
[lower (if (< (between/c-low ctc) min-n)
|
||||
min-n
|
||||
(between/c-low ctc))])
|
||||
(+ (random (- upper lower))
|
||||
lower))))))
|
||||
|
||||
(define-syntax (check-unary-between/c stx)
|
||||
(syntax-case stx ()
|
||||
|
@ -514,11 +534,28 @@
|
|||
(define (</c x)
|
||||
(flat-named-contract
|
||||
`(</c ,x)
|
||||
(λ (y) (and (real? y) (< y x)))))
|
||||
(λ (y) (and (real? y) (< y x)))
|
||||
(λ (fuel)
|
||||
(let* ([max-n 2147483647]
|
||||
[min-n -2147483648]
|
||||
[upper (if (> x max-n)
|
||||
max-n
|
||||
x)])
|
||||
(+ (random (- upper min-n))
|
||||
min-n)))))
|
||||
|
||||
(define (>/c x)
|
||||
(flat-named-contract
|
||||
`(>/c ,x)
|
||||
(λ (y) (and (real? y) (> y x)))))
|
||||
`(>/c ,x)
|
||||
(λ (y) (and (real? y) (> y x)))
|
||||
(λ (fuel)
|
||||
(let* ([max-n 2147483647]
|
||||
[min-n -2147483648]
|
||||
[lower (if (< x min-n)
|
||||
min-n
|
||||
x)])
|
||||
(+ (random (- max-n lower))
|
||||
lower)))))
|
||||
|
||||
(define/final-prop (integer-in start end)
|
||||
(unless (and (integer? start)
|
||||
|
@ -546,6 +583,19 @@
|
|||
(build-compound-type-name 'not/c ctc)
|
||||
(λ (x) (not (pred x))))))
|
||||
|
||||
(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 (listof-exercise el-ctc)
|
||||
(λ (f n-tests size env)
|
||||
#t))
|
||||
|
||||
(define-syntax (*-listof stx)
|
||||
(syntax-case stx ()
|
||||
[(_ predicate? type-name name)
|
||||
|
@ -572,25 +622,118 @@
|
|||
(make-flat-contract
|
||||
#:name ctc-name
|
||||
#:first-order fo-check
|
||||
#:projection (ho-check (λ (p v) (for-each p v) v)))]
|
||||
#:projection (ho-check (λ (p v) (for-each p v) v))
|
||||
#:generate (listof-generate ctc))]
|
||||
[(chaperone-contract? ctc)
|
||||
(make-chaperone-contract
|
||||
#:name ctc-name
|
||||
#:first-order fo-check
|
||||
#:projection (ho-check (λ (p v) (map p v))))]
|
||||
#:projection (ho-check (λ (p v) (map p v)))
|
||||
#:generate (listof-generate ctc))]
|
||||
[else
|
||||
(make-contract
|
||||
#:name ctc-name
|
||||
#:first-order fo-check
|
||||
#:projection (ho-check (λ (p v) (map p v))))]))))]))
|
||||
#:projection (ho-check (λ (p v) (map p v)))
|
||||
)]))))]))
|
||||
|
||||
(define listof-func (*-listof list? list listof))
|
||||
(define/subexpression-pos-prop (listof x) (listof-func x))
|
||||
|
||||
(define (non-empty-list? x) (and (pair? x) (list? (cdr x))))
|
||||
#|
|
||||
(define (listof element-ctc)
|
||||
; (printf "bla")
|
||||
(if (flat-contract? element-ctc)
|
||||
(begin
|
||||
; (printf "flat\n")
|
||||
(make-listof-flat/c element-ctc))
|
||||
(begin
|
||||
; (printf "non-flat\n")
|
||||
(make-listof/c element-ctc))))
|
||||
|#
|
||||
|
||||
;(*-immutableof list? map andmap list listof))
|
||||
|
||||
(define-struct listof-flat/c (element-ctc)
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:flat-contract
|
||||
(build-flat-contract-property
|
||||
#:name
|
||||
(λ (ctc)
|
||||
(build-compound-type-name 'listof (object-name (listof-flat/c-element-ctc ctc))))
|
||||
#|
|
||||
#:projection
|
||||
(λ (ctc)
|
||||
; (let* ([content-pred? (listof-flat/c-element-ctc ctc)])
|
||||
(let* ([content-ctc (listof-flat/c-element-ctc ctc)]
|
||||
[content-pred? (flat-contract-predicate ctc)])
|
||||
(λ (blame)
|
||||
(λ (x)
|
||||
(unless (and (list? x) (andmap content-pred? x))
|
||||
(raise-blame-error
|
||||
blame
|
||||
x
|
||||
"expected <~a>, given: ~e"
|
||||
'type-name
|
||||
x))
|
||||
#t))))
|
||||
|#
|
||||
#:first-order
|
||||
(λ (ctc)
|
||||
(let ([content-pred? (listof-flat/c-element-ctc ctc)])
|
||||
(λ (val)
|
||||
(and (list? val) (andmap content-pred? val)))))
|
||||
#:generate
|
||||
(λ (ctc)
|
||||
; #f)
|
||||
(listof-generate (listof-flat/c-element-ctc ctc)))
|
||||
#:exercise
|
||||
(λ (ctc)
|
||||
; #f)))
|
||||
(listof-exercise (listof-flat/c-element-ctc ctc)))))
|
||||
|
||||
|
||||
|
||||
|
||||
(define-struct listof/c (element-ctc)
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:name
|
||||
(λ (ctc)
|
||||
(build-compound-type-name 'listof (object-name (listof/c-element-ctc ctc))))
|
||||
#:projection
|
||||
(λ (ctc)
|
||||
(let* ([el-ctc (listof/c-element-ctc ctc)]
|
||||
[proj (contract-projection el-ctc)])
|
||||
(λ (blame)
|
||||
(let ([p-app (proj blame)])
|
||||
(λ (val)
|
||||
(unless (list? val)
|
||||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
"expected <~a>, given: ~e"
|
||||
'type-name
|
||||
val))
|
||||
(map p-app val))))))
|
||||
#:first-order
|
||||
(λ (ctc)
|
||||
list?)
|
||||
#:generate
|
||||
(λ (ctc)
|
||||
; #f)
|
||||
(listof-generate (listof/c-element-ctc ctc)))
|
||||
#:exercise
|
||||
(λ (ctc)
|
||||
; #f)))
|
||||
(listof-exercise (listof/c-element-ctc ctc)))))
|
||||
|
||||
(define (non-empty-list? x) (and (pair? x) (list (cdr x))))
|
||||
(define non-empty-listof-func (*-listof non-empty-list? non-empty-list non-empty-listof))
|
||||
(define/subexpression-pos-prop (non-empty-listof a) (non-empty-listof-func a))
|
||||
|
||||
|
||||
(define cons/c-main-function
|
||||
(λ (car-c cdr-c)
|
||||
(let* ([ctc-car (coerce-contract 'cons/c car-c)]
|
||||
|
@ -851,13 +994,13 @@
|
|||
(coerce-contract 'contract-projection ctc)))
|
||||
|
||||
(define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
|
||||
(define (flat-named-contract name predicate)
|
||||
(define (flat-named-contract name predicate [generate (make-generate-ctc-fail)])
|
||||
(cond
|
||||
[(and (procedure? predicate)
|
||||
(procedure-arity-includes? predicate 1))
|
||||
(make-predicate-contract name predicate)]
|
||||
(make-predicate-contract name predicate generate)]
|
||||
[(flat-contract? predicate)
|
||||
(make-predicate-contract name (flat-contract-predicate predicate))]
|
||||
(make-predicate-contract name (flat-contract-predicate predicate) generate)]
|
||||
[else
|
||||
(error 'flat-named-contract
|
||||
"expected a flat contract or procedure of arity 1 as second argument, got ~e"
|
||||
|
|
|
@ -1,6 +1,7 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "blame.rkt")
|
||||
(require "blame.rkt"
|
||||
"generate-base.rkt")
|
||||
|
||||
(provide prop:contract
|
||||
contract-struct?
|
||||
|
@ -8,6 +9,8 @@
|
|||
contract-struct-first-order
|
||||
contract-struct-projection
|
||||
contract-struct-stronger?
|
||||
contract-struct-generate
|
||||
contract-struct-exercise
|
||||
|
||||
prop:flat-contract
|
||||
flat-contract-struct?
|
||||
|
@ -34,7 +37,7 @@
|
|||
;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-struct contract-property [ name first-order projection stronger generator ]
|
||||
(define-struct contract-property [ name first-order projection stronger generate exercise ]
|
||||
#:omit-define-syntaxes)
|
||||
|
||||
(define (contract-property-guard prop info)
|
||||
|
@ -73,6 +76,23 @@
|
|||
[stronger (contract-property-stronger prop)])
|
||||
(stronger a b)))
|
||||
|
||||
(define (contract-struct-generate c)
|
||||
(let* ([prop (contract-struct-property c)]
|
||||
[generate (contract-property-generate prop)])
|
||||
(if (procedure? generate)
|
||||
; FIXME: Call needs to take multiple arguments
|
||||
(generate c)
|
||||
(begin
|
||||
(count-missing-generate (contract-struct-name c))
|
||||
(make-generate-ctc-fail)))))
|
||||
|
||||
(define (contract-struct-exercise c)
|
||||
(let* ([prop (contract-struct-property c)]
|
||||
[exercise (contract-property-exercise prop)])
|
||||
(if (procedure? exercise)
|
||||
(exercise c)
|
||||
(make-generate-ctc-fail))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; Chaperone Contract Property
|
||||
|
@ -154,7 +174,8 @@
|
|||
#:first-order [get-first-order #f]
|
||||
#:projection [get-projection #f]
|
||||
#:stronger [stronger #f]
|
||||
#:generator [generator #f])
|
||||
#:generate [generate (make-generate-ctc-fail)]
|
||||
#:exercise [exercise (make-generate-ctc-fail)])
|
||||
|
||||
(let* ([get-name (or get-name (lambda (c) default-name))]
|
||||
[get-first-order (or get-first-order get-any?)]
|
||||
|
@ -165,7 +186,7 @@
|
|||
get-name get-first-order)])]
|
||||
[stronger (or stronger weakest)])
|
||||
|
||||
(mk get-name get-first-order get-projection stronger generator)))
|
||||
(mk get-name get-first-order get-projection stronger generate exercise )))
|
||||
|
||||
(define build-contract-property
|
||||
(build-property make-contract-property 'anonymous-contract values))
|
||||
|
@ -219,7 +240,7 @@
|
|||
;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-struct make-contract [ name first-order projection stronger ]
|
||||
(define-struct make-contract [ name first-order projection stronger generate exercise ]
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
|
@ -227,9 +248,10 @@
|
|||
#:first-order (lambda (c) (make-contract-first-order c))
|
||||
#:projection (lambda (c) (make-contract-projection c))
|
||||
#:stronger (lambda (a b) ((make-contract-stronger a) a b))
|
||||
#:generator #f))
|
||||
#:generate (lambda (c) ((make-contract-generate c)))
|
||||
#:exercise (lambda (c) ((make-contract-exercise c)))))
|
||||
|
||||
(define-struct make-chaperone-contract [ name first-order projection stronger ]
|
||||
(define-struct make-chaperone-contract [ name first-order projection stronger generate exercise ]
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:chaperone-contract
|
||||
(build-chaperone-contract-property
|
||||
|
@ -237,9 +259,10 @@
|
|||
#:first-order (lambda (c) (make-chaperone-contract-first-order c))
|
||||
#:projection (lambda (c) (make-chaperone-contract-projection c))
|
||||
#:stronger (lambda (a b) ((make-chaperone-contract-stronger a) a b))
|
||||
#:generator #f))
|
||||
#:generate (lambda (c) (make-chaperone-contract-generate c))
|
||||
#:exercise (lambda (c) (make-chaperone-contract-exercise c))))
|
||||
|
||||
(define-struct make-flat-contract [ name first-order projection stronger ]
|
||||
(define-struct make-flat-contract [ name first-order projection stronger generate exercise ]
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:flat-contract
|
||||
(build-flat-contract-property
|
||||
|
@ -247,20 +270,23 @@
|
|||
#:first-order (lambda (c) (make-flat-contract-first-order c))
|
||||
#:projection (lambda (c) (make-flat-contract-projection c))
|
||||
#:stronger (lambda (a b) ((make-flat-contract-stronger a) a b))
|
||||
#:generator #f))
|
||||
#:generate (lambda (c) (make-flat-contract-generate c))
|
||||
#:exercise (lambda (c) (make-chaperone-contract-exercise c))))
|
||||
|
||||
(define ((build-contract mk default-name)
|
||||
#:name [name #f]
|
||||
#:first-order [first-order #f]
|
||||
#:projection [projection #f]
|
||||
#:stronger [stronger #f])
|
||||
#:stronger [stronger #f]
|
||||
#:generate [generate (make-generate-ctc-fail)]
|
||||
#:exercise [exercise (make-generate-ctc-fail)] )
|
||||
|
||||
(let* ([name (or name default-name)]
|
||||
[first-order (or first-order any?)]
|
||||
[projection (or projection (first-order-projection name first-order))]
|
||||
[stronger (or stronger as-strong?)])
|
||||
|
||||
(mk name first-order projection stronger)))
|
||||
(mk name first-order projection stronger generate exercise)))
|
||||
|
||||
(define (as-strong? a b)
|
||||
(procedure-closure-contents-eq?
|
||||
|
@ -275,3 +301,4 @@
|
|||
|
||||
(define make-flat-contract
|
||||
(build-contract make-make-flat-contract 'anonymous-flat-contract))
|
||||
|
||||
|
|
89
collects/racket/contract/private/rand.rkt
Normal file
89
collects/racket/contract/private/rand.rkt
Normal file
|
@ -0,0 +1,89 @@
|
|||
#lang racket/base
|
||||
|
||||
(require (for-syntax scheme/base))
|
||||
|
||||
(provide rand
|
||||
rand-seed
|
||||
rand-choice
|
||||
rand-range
|
||||
permute
|
||||
oneof)
|
||||
|
||||
|
||||
;; random generator
|
||||
|
||||
(define my-generator (make-pseudo-random-generator))
|
||||
(define (rand [x #f])
|
||||
(if x
|
||||
(random x my-generator)
|
||||
(random my-generator)))
|
||||
|
||||
|
||||
(define (rand-seed x)
|
||||
(parameterize ([current-pseudo-random-generator my-generator])
|
||||
(random-seed x)))
|
||||
|
||||
(rand-seed 0)
|
||||
|
||||
(define-syntax (rand-choice stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (a case1 case2 ...) ...)
|
||||
(begin
|
||||
(let ([ns (let loop ([sum 0]
|
||||
[as (syntax->list #'(a ...))])
|
||||
(cond
|
||||
[(null? as) (raise-syntax-error #f "expected at least one case" stx)]
|
||||
[(null? (cdr as))
|
||||
(syntax-case (car as) (else)
|
||||
[else (list (- 1 sum))]
|
||||
[_ (raise-syntax-error #f "expected last option to be `else'" stx (car as))])]
|
||||
[else
|
||||
(let ([n (syntax-e (car as))])
|
||||
(unless (and (real? n)
|
||||
(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)))
|
||||
(unless (< (+ n sum) 1)
|
||||
(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)]
|
||||
[choices (map (λ (x) (* (numerator x) (apply * (remove
|
||||
(denominator x) dens))))
|
||||
ns)])
|
||||
#`(rand-choice/proc '(#,@choices)
|
||||
#,(apply * dens)
|
||||
(list (λ () case1 case2 ...) ...)))))]))
|
||||
|
||||
(define (rand-choice/proc choices prod thunks)
|
||||
(let ([choice (rand prod)])
|
||||
(let loop ([n choice]
|
||||
[nums choices]
|
||||
[thunks thunks])
|
||||
(cond
|
||||
[(null? nums) (error 'rand-chance "internal error!")]
|
||||
[else
|
||||
(cond
|
||||
[(< n (car nums))
|
||||
((car thunks))]
|
||||
[else
|
||||
(loop (- n (car nums))
|
||||
(cdr nums)
|
||||
(cdr thunks))])]))))
|
||||
|
||||
; oneof :: [a] -> a
|
||||
; Randomly chooses one of the values from a given list
|
||||
(define (oneof a-list)
|
||||
(list-ref a-list (random (length a-list))))
|
||||
|
||||
; fisher-yates shuffle
|
||||
(define (permute a-list)
|
||||
(do ((v (list->vector a-list)) (n (length a-list) (- n 1)))
|
||||
((zero? n) (vector->list v))
|
||||
(let* ((r (random n)) (t (vector-ref v r)))
|
||||
(vector-set! v r (vector-ref v (- n 1)))
|
||||
(vector-set! v (- n 1) t))))
|
||||
|
||||
(define (rand-range lower upper)
|
||||
(+ lower (rand (- upper lower))))
|
|
@ -6,7 +6,7 @@
|
|||
@(define contract-eval
|
||||
(lambda ()
|
||||
(let ([the-eval (make-base-eval)])
|
||||
(the-eval '(require racket/contract))
|
||||
(the-eval '(require racket/contract racket/contract/parametric))
|
||||
the-eval)))
|
||||
|
||||
@title[#:tag "contracts" #:style 'toc]{Contracts}
|
||||
|
@ -84,10 +84,14 @@ Constructs a @tech{flat contract} from @racket[predicate]. A value
|
|||
satisfies the contract if the predicate returns a true value.}
|
||||
|
||||
|
||||
@defproc[(flat-named-contract [type-name any/c]
|
||||
[predicate (or/c flat-contract? (any/c . -> . any))])
|
||||
@defproc[(flat-named-contract [type-name any/c]
|
||||
[predicate (or/c flat-contract? (any/c . -> . any))]
|
||||
[#:generate generator (-> contract (-> int? 'a-val))])
|
||||
flat-contract?]{
|
||||
|
||||
The generator argument adds a generator for the flat-named-contract. See
|
||||
@racket[contract-generate] for more information.
|
||||
|
||||
On predicates like @racket[flat-contract], but the first argument must be the
|
||||
(quoted) name of a contract used for error reporting.
|
||||
For example,
|
||||
|
@ -2083,3 +2087,11 @@ parts of the contract system.
|
|||
struct and returns a projection function that checks the contract.
|
||||
|
||||
}
|
||||
@section{Random generation}
|
||||
|
||||
@defproc[(contract-generate [ctc contract?] [fuel int?]) any/c]{
|
||||
Attempts to randomly generate a value which will match the contract. The fuel
|
||||
argument limits the depth that the argument generation can go and thus the
|
||||
memory used. In order to know which contracts to generate, it may be necessary
|
||||
to add a generator for the generate keyword argument in @racket[struct]
|
||||
}
|
||||
|
|
|
@ -100,7 +100,9 @@ override the default @racket[equal?] definition through the
|
|||
[immutables (listof exact-nonnegative-integer?)
|
||||
null]
|
||||
[guard (or/c procedure? #f) #f]
|
||||
[constructor-name (or/c symbol? #f) #f])
|
||||
[constructor-name (or/c symbol? #f) #f]
|
||||
[generate (-> contract? (-> int? any/c))]
|
||||
[exercise (-> contract? (-> int? any/c any/c))])
|
||||
(values struct-type?
|
||||
struct-constructor-procedure?
|
||||
struct-predicate-procedure?
|
||||
|
@ -174,6 +176,14 @@ If @racket[constructor-name] is not @racket[#f], it is used as the
|
|||
name of the generated @tech{constructor} procedure as returned by
|
||||
@racket[object-name] or in the printed form of the constructor value.
|
||||
|
||||
The @racket[generate] argument is used to define a new generator for
|
||||
this structure type, which can be used to create random instances of
|
||||
the structure type. For more information see @racket[contract-generate].
|
||||
|
||||
The @racket[exercise] argument allows you to define a function to verify
|
||||
that a given value is an instance of your contract. This will also be used
|
||||
for random generation.
|
||||
|
||||
The result of @racket[make-struct-type] is five values:
|
||||
|
||||
@itemize[
|
||||
|
|
68
collects/tests/racket/contract-rand-test.rkt
Normal file
68
collects/tests/racket/contract-rand-test.rkt
Normal file
|
@ -0,0 +1,68 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/contract
|
||||
rackunit
|
||||
rackunit/text-ui
|
||||
net/url)
|
||||
|
||||
(define (test-contract-generation ctc
|
||||
[monkey-with values]
|
||||
#:size [size 10])
|
||||
;; generator : number[of tests] number[size bound] ??[env] -> any
|
||||
(define example-vals (contract-generate ctc size))
|
||||
(monkey-with (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?)))
|
||||
))
|
||||
|
||||
(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 (</c 0))))
|
||||
(check-not-exn (λ () (test-contract-generation (or/c boolean? boolean?))))
|
||||
))
|
||||
|
||||
(define func-tests
|
||||
(test-suite
|
||||
"Function contracts"
|
||||
(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?))
|
||||
+)))
|
||||
;(check-not-exn (λ () (test-contract-generation (-> (or/c bytes string?)
|
||||
; url?)
|
||||
; "test")))
|
||||
))
|
||||
|
||||
;(define net/url-tests
|
||||
; (test-suite "net/url contracts"
|
||||
|
||||
(define ctc-gen-tests
|
||||
(test-suite
|
||||
"All random contract generation tests"
|
||||
pred-tests
|
||||
flat-ctc-tests
|
||||
func-tests))
|
||||
|
||||
|
||||
(run-tests ctc-gen-tests)
|
Loading…
Reference in New Issue
Block a user