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:
parent
67f215eec0
commit
39195bd04f
|
@ -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?
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
Loading…
Reference in New Issue
Block a user