added the #:generator argument to the contract property maker

This commit is contained in:
Robby Findler 2010-04-15 23:29:39 -04:00
parent 4587795d40
commit bcbdcc2eaf
2 changed files with 35 additions and 11 deletions

View File

@ -27,7 +27,7 @@
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-struct contract-property [ name first-order projection stronger ] (define-struct contract-property [ name first-order projection stronger generator ]
#:omit-define-syntaxes) #:omit-define-syntaxes)
(define (contract-property-guard prop info) (define (contract-property-guard prop info)
@ -112,7 +112,8 @@
#:name [get-name #f] #:name [get-name #f]
#:first-order [get-first-order #f] #:first-order [get-first-order #f]
#:projection [get-projection #f] #:projection [get-projection #f]
#:stronger [stronger #f]) #:stronger [stronger #f]
#:generator [generator #f])
(let* ([get-name (or get-name (lambda (c) default-name))] (let* ([get-name (or get-name (lambda (c) default-name))]
[get-first-order (or get-first-order get-any?)] [get-first-order (or get-first-order get-any?)]
@ -121,7 +122,7 @@
get-name get-first-order))] get-name get-first-order))]
[stronger (or stronger weakest)]) [stronger (or stronger weakest)])
(mk get-name get-first-order get-projection stronger))) (mk get-name get-first-order get-projection stronger generator)))
(define build-contract-property (define build-contract-property
(build-property make-contract-property 'anonymous-contract)) (build-property make-contract-property 'anonymous-contract))
@ -156,7 +157,8 @@
(lambda (c) (make-contract-name c)) (lambda (c) (make-contract-name c))
(lambda (c) (make-contract-first-order c)) (lambda (c) (make-contract-first-order c))
(lambda (c) (make-contract-projection c)) (lambda (c) (make-contract-projection c))
(lambda (a b) ((make-contract-stronger a) a b)))) (lambda (a b) ((make-contract-stronger a) a b))
#f))
(define-struct make-flat-contract [ name first-order projection stronger ] (define-struct make-flat-contract [ name first-order projection stronger ]
#:omit-define-syntaxes #:omit-define-syntaxes
@ -166,7 +168,8 @@
(lambda (c) (make-flat-contract-name c)) (lambda (c) (make-flat-contract-name c))
(lambda (c) (make-flat-contract-first-order c)) (lambda (c) (make-flat-contract-first-order c))
(lambda (c) (make-flat-contract-projection c)) (lambda (c) (make-flat-contract-projection c))
(lambda (a b) ((make-flat-contract-stronger a) a b))))) (lambda (a b) ((make-flat-contract-stronger a) a b))
#f)))
(define ((build-contract mk default-name) (define ((build-contract mk default-name)
#:name [name #f] #:name [name #f]

View File

@ -1246,7 +1246,15 @@ constructed by @scheme[build-flat-contract-property].
(if ((get-first-order c) x) (if ((get-first-order c) x)
x x
(raise-blame-error (raise-blame-error
b x "expected <~a>, given: ~e" (get-name c) x)))))]) b x "expected <~a>, given: ~e" (get-name c) x)))))]
[#:stronger
stronger
(or/c (-> contract? contract? boolean?) #f)
#f]
[#:generator
generator
(or/c (-> number? (listof (list any/c contract?)) any/c) #f)
#f])
flat-contract-property?] flat-contract-property?]
@defproc[(build-contract-property @defproc[(build-contract-property
[#:name [#:name
@ -1266,7 +1274,15 @@ constructed by @scheme[build-flat-contract-property].
(if ((get-first-order c) x) (if ((get-first-order c) x)
x x
(raise-blame-error (raise-blame-error
b x "expected <~a>, given: ~e" (get-name c) x)))))]) b x "expected <~a>, given: ~e" (get-name c) x)))))]
[#:stronger
stronger
(or/c (-> contract? contract? boolean?) #f)
#f]
[#:generator
generator
(or/c (-> number? (listof (list any/c contract?)) any/c) #f)
#f])
contract-property?] contract-property?]
)]{ )]{
@ -1274,11 +1290,16 @@ These functions build the arguments for @scheme[prop:contract] and
@scheme[prop:flat-contract], respectively. @scheme[prop:flat-contract], respectively.
A @deftech{contract property} specifies the behavior of a structure when used as A @deftech{contract property} specifies the behavior of a structure when used as
a contract. It is specified in terms of three accessors: @scheme[get-name], a contract. It is specified in terms of five accessors: @scheme[get-name],
which produces a description to @scheme[display] during a contract violation; which produces a description to @scheme[write] as part of a contract violation;
@scheme[get-first-order], which produces a first order predicate to be used by @scheme[get-first-order], which produces a first order predicate to be used by
@scheme[contract-first-order-passes?]; and @scheme[get-projection], which @scheme[contract-first-order-passes?]; @scheme[get-projection], which
produces a blame-tracking projection defining the behavior of the contract. produces a blame-tracking projection defining the behavior of the contract;
@scheme[stronger], which is a predicate that determines if one contract this contract
(passed in the first argument) is stronger than some other contract (passed in the second argument);
and @scheme[generator], which makes a random value that matches the contract,
given a size bound and an environment from which to draw interesting values.
These accessors are passed as (optional) keyword arguments to These accessors are passed as (optional) keyword arguments to
@scheme[build-contract-property], and are applied to instances of the @scheme[build-contract-property], and are applied to instances of the
appropriate structure type by the contract system. Their results are used appropriate structure type by the contract system. Their results are used