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

Some small cleanups of Andy's contract generator code

Browse Source
This commit is contained in:
Robby Findler 2011-11-23 22:53:44 -06:00
parent b8847a53bf
commit b7d2d5da62
5 changed files with 53 additions and 133 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -101,16 +101,18 @@
(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)))))
(define (contract-generate ctc fuel [fail (λ ()
(error 'contract-generate
"Unable to construct any generator for contract: ~s"
(contract-struct-name (coerce-contract 'contract-generate ctc))))])
(let ([def-ctc (coerce-contract 'contract-generate ctc)])
(printf "def-ctc ~s\n" def-ctc)
(parameterize ([generate-env (make-hash)])
; choose randomly
(let ([val (generate/choose def-ctc fuel)])
(if (generate-ctc-fail? val)
(fail)
val)))))
; Iterates through generation methods until failure. Returns
; generate-ctc-fail if no value could be generated

10
collects/racket/contract/private/guts.rkt
View File

@ -269,6 +269,8 @@
(if (symbol? (eq-contract-val ctc))
`',(eq-contract-val ctc)
(eq-contract-val ctc)))
#:generate
(λ (ctc) (λ (fuel) (eq-contract-val ctc)))
#:stronger
(λ (this that)
(and (eq-contract? that)
@ -282,7 +284,9 @@
#:stronger
(λ (this that)
(and (equal-contract? that)
(equal? (equal-contract-val this) (equal-contract-val that))))))
(equal? (equal-contract-val this) (equal-contract-val that))))
#:generate
(λ (ctc) (λ (fuel) (equal-contract-val ctc)))))
(define-struct =-contract (val)
#:property prop:flat-contract
@ -292,7 +296,9 @@
#:stronger
(λ (this that)
(and (=-contract? that)
(= (=-contract-val this) (=-contract-val that))))))
(= (=-contract-val this) (=-contract-val that))))
#:generate
(λ (ctc) (λ (fuel) (=-contract-val ctc)))))
(define-struct regexp/c (reg)
#:property prop:flat-contract

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

@ -598,7 +598,7 @@
(define-syntax (*-listof stx)
(syntax-case stx ()
[(_ predicate? type-name name)
[(_ predicate? type-name name generate)
(identifier? (syntax predicate?))
(syntax
(λ (input)
@ -623,117 +623,26 @@
#:name ctc-name
#:first-order fo-check
#:projection (ho-check (λ (p v) (for-each p v) v))
#:generate (listof-generate ctc))]
#:generate (generate ctc))]
[(chaperone-contract? ctc)
(make-chaperone-contract
#:name ctc-name
#:first-order fo-check
#:projection (ho-check (λ (p v) (map p v)))
#:generate (listof-generate ctc))]
#:generate (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 listof-func (*-listof list? list listof listof-generate))
(define/subexpression-pos-prop (listof x) (listof-func 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 non-empty-listof-func (*-listof non-empty-list? non-empty-list non-empty-listof (λ (ctc) (make-generate-ctc-fail))))
(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)]
@ -994,19 +903,18 @@
(coerce-contract 'contract-projection ctc)))
(define (flat-contract predicate) (coerce-flat-contract 'flat-contract 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 generate)]
[(flat-contract? 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"
predicate)]))
(define (flat-named-contract name predicate [generate #f])
(let ([generate (or generate (make-generate-ctc-fail))])
(cond
[(and (procedure? predicate)
(procedure-arity-includes? predicate 1))
(make-predicate-contract name predicate generate)]
[(flat-contract? 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"
predicate)])))
(define printable/c
(flat-named-contract

4
collects/racket/contract/private/prop.rkt
View File

@ -186,7 +186,7 @@
get-name get-first-order)])]
[stronger (or stronger weakest)])
(mk get-name get-first-order get-projection stronger generate exercise )))
(mk get-name get-first-order get-projection stronger generate exercise)))
(define build-contract-property
(build-property make-contract-property 'anonymous-contract values))
@ -271,7 +271,7 @@
#:projection (lambda (c) (make-flat-contract-projection c))
#:stronger (lambda (a b) ((make-flat-contract-stronger a) a b))
#:generate (lambda (c) (make-flat-contract-generate c))
#:exercise (lambda (c) (make-chaperone-contract-exercise c))))
#:exercise (lambda (c) (make-flat-contract-exercise c))))
(define ((build-contract mk default-name)
#:name [name #f]

22
collects/scribblings/reference/contracts.scrbl
View File

@ -86,13 +86,10 @@ 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))]
[#:generate generator (-> contract (-> int? 'a-val))])
[generator (or/c #f (-> contract (-> int? any))) #f])
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
On predicates, behaves like @racket[flat-contract], but the first argument must be the
(quoted) name of a contract used for error reporting.
For example,
@racketblock[(flat-named-contract
@ -102,6 +99,9 @@ turns the predicate into a contract with the name @tt{odd-integer}.
On flat contracts, the new flat contract is the same as the old except for
the name.
The generator argument adds a generator for the flat-named-contract. See
@racket[contract-generate] for more information.
}
@defthing[any/c flat-contract?]{
@ -2089,9 +2089,13 @@ parts of the contract system.
}
@section{Random generation}
@defproc[(contract-generate [ctc contract?] [fuel int?]) any/c]{
@defproc[(contract-generate [ctc contract?] [fuel int?] [fail (-> any/c) (λ () (error ...))]) 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]
argument limits how hard the generator tries to generate a contract and is a rough
limit of the size of the resulting value.
The generator may fail to generate a contract, either because some contracts
do not have corresponding generators (for example, not all predicates have
generators) or because there is not enough fuel. In either case, the
thunk @racket[fail] is invoked.
}