add generator for (and/c real? (not/c negative?)) and (and/c rational? (not/c negative?))

and fix -> generator for mandatory keyword arguments
This commit is contained in:
Robby Findler 2014-05-16 22:39:13 -05:00
parent 67f215eec0
commit 39195bd04f
3 changed files with 60 additions and 8 deletions

View File

@ -36,6 +36,8 @@
(check-not-exn (λ () (test-contract-generation (</c 0.0))))
(check-not-exn (λ () (test-contract-generation (=/c 0))))
(check-not-exn (λ () (test-contract-generation (=/c 0.0))))
(check-not-exn (λ () (test-contract-generation (and/c real? (not/c negative?)))))
(check-not-exn (λ () (test-contract-generation (and/c rational? (not/c negative?)))))
(check-not-exn (λ () (test-contract-generation (or/c boolean? boolean?))))
(check-not-exn (λ () (test-contract-generation (cons/c integer? boolean?))))
(check-not-exn (λ () (test-contract-generation any/c)))
@ -167,6 +169,14 @@
(contract-exercise #:fuel N . exps)
(void))))]))
(check-exercise
10
pos-exn-or-silence?
(contract (-> #:b boolean? any/c)
(λ (#:b b) b)
'pos
'neg))
(check-exercise
1
pos-exn?

View File

@ -754,24 +754,36 @@
[else (λ (fuel) #f)]))
(define (->-exercise ctc)
(define dom-ctcs (base->-doms ctc))
(define rng-ctcs (base->-rngs ctc))
(define dom-ctcs (for/list ([doms (in-list (base->-doms ctc))]
[i (in-range (base->-min-arity ctc))])
doms))
(define dom-kwd-infos (for/list ([dom-kwd (in-list (base->-kwd-infos ctc))]
#:when (kwd-info-mandatory? dom-kwd))
dom-kwd))
(define dom-kwds (map kwd-info-kwd dom-kwd-infos))
(cond
[(and (equal? (length dom-ctcs) (base->-min-arity ctc))
(not (base->-rest ctc)))
[(not (base->-rest ctc))
(λ (fuel)
(define gens
(for/list ([dom-ctc (in-list dom-ctcs)])
(generate/choose dom-ctc fuel)))
(define kwd-gens
(for/list ([kwd-info (in-list dom-kwd-infos)])
(generate/choose (kwd-info-ctc kwd-info) fuel)))
(define env (generate-env))
(cond
[(andmap values gens)
[(and (andmap values gens)
(andmap values kwd-gens))
(values
(λ (f)
(call-with-values
(λ ()
(apply
(keyword-apply
f
dom-kwds
(for/list ([kwd-gen (in-list kwd-gens)])
(kwd-gen))
(for/list ([gen (in-list gens)])
(gen))))
(λ results

View File

@ -175,6 +175,33 @@
this-ctcs
that-ctcs)))))
(define (and/c-generate? ctc)
(cond
[(and/c-check-nonneg ctc real?) => values]
[(and/c-check-nonneg ctc rational?) => values]
[else (λ (fuel) #f)]))
(define (and/c-check-nonneg ctc pred)
(define sub-contracts (base-and/c-ctcs ctc))
(cond
[(are-stronger-contracts? (list pred (not/c negative?))
sub-contracts)
(define go (hash-ref predicate-generator-table pred))
(λ (fuel)
(λ ()
(abs (go fuel))))]
[else #f]))
(define (are-stronger-contracts? c1s c2s)
(let loop ([c1s c1s]
[c2s c2s])
(cond
[(and (null? c1s) (null? c2s)) #t]
[(and (pair? c1s) (pair? c2s))
(and (contract-stronger? (car c1s) (car c2s))
(loop (cdr c1s) (cdr c2s)))]
[else #f])))
(define-struct base-and/c (ctcs))
(define-struct (first-order-and/c base-and/c) (predicates)
#:property prop:custom-write custom-write-property-proc
@ -184,7 +211,8 @@
#:val-first-projection first-order-val-first-and-proj
#:name and-name
#:first-order and-first-order
#:stronger and-stronger?))
#:stronger and-stronger?
#:generate and/c-generate?))
(define-struct (chaperone-and/c base-and/c) ()
#:property prop:custom-write custom-write-property-proc
#:property prop:chaperone-contract
@ -194,7 +222,8 @@
#:val-first-projection val-first-and-proj
#:name and-name
#:first-order and-first-order
#:stronger and-stronger?)))
#:stronger and-stronger?
#:generate and/c-generate?)))
(define-struct (impersonator-and/c base-and/c) ()
#:property prop:custom-write custom-write-property-proc
#:property prop:contract
@ -203,7 +232,8 @@
#:val-first-projection val-first-and-proj
#:name and-name
#:first-order and-first-order
#:stronger and-stronger?))
#:stronger and-stronger?
#:generate and/c-generate?))
(define/subexpression-pos-prop (and/c . raw-fs)