add a random generator for struct/c
This is actually done by adding a generator for struct/dc in the case that there are no dependencies, so it'll also work for such contracts.
This commit is contained in:
parent
c64d70abc6
commit
5ed9b65ae5
|
@ -54,6 +54,30 @@
|
||||||
(or/c (cons/c any/c (cons/c any/c even-length-list/c))
|
(or/c (cons/c any/c (cons/c any/c even-length-list/c))
|
||||||
'())))))
|
'())))))
|
||||||
|
|
||||||
|
(check-not-exn
|
||||||
|
(λ ()
|
||||||
|
(struct s (a b) #:transparent)
|
||||||
|
(test-contract-generation
|
||||||
|
(struct/dc s [a integer?] [b boolean?]))))
|
||||||
|
|
||||||
|
(check-not-exn
|
||||||
|
(λ ()
|
||||||
|
(struct s (a b) #:transparent)
|
||||||
|
(test-contract-generation
|
||||||
|
(struct/c s integer? boolean?))))
|
||||||
|
|
||||||
|
(check-not-exn
|
||||||
|
(λ ()
|
||||||
|
(struct node (v l r) #:transparent)
|
||||||
|
(test-contract-generation
|
||||||
|
(flat-rec-contract
|
||||||
|
tree/c
|
||||||
|
(or/c (struct/dc node
|
||||||
|
[v integer?]
|
||||||
|
[l tree/c]
|
||||||
|
[r tree/c])
|
||||||
|
#f)))))
|
||||||
|
|
||||||
(check-exn exn:fail? (λ () ((test-contract-generation (-> char? integer?)) 0)))
|
(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?)) 1)))
|
||||||
(check-not-exn (λ () ((test-contract-generation (-> (-> integer? integer?) boolean?)) +)))
|
(check-not-exn (λ () ((test-contract-generation (-> (-> integer? integer?) boolean?)) +)))
|
||||||
|
|
|
@ -195,6 +195,31 @@
|
||||||
(and ((flat-contract-predicate (apply (dep-dep-proc subc) args)) val)
|
(and ((flat-contract-predicate (apply (dep-dep-proc subc) args)) val)
|
||||||
(loop (cdr subcs) next-args))])])])))))
|
(loop (cdr subcs) next-args))])])])))))
|
||||||
|
|
||||||
|
(define ((struct/dc-generate ctc) fuel)
|
||||||
|
(define constructor (base-struct/dc-constructor ctc))
|
||||||
|
(and constructor
|
||||||
|
(let loop ([subcs (base-struct/dc-subcontracts ctc)]
|
||||||
|
[gens '()])
|
||||||
|
(cond
|
||||||
|
[(null? subcs)
|
||||||
|
(λ ()
|
||||||
|
(let loop ([gens gens]
|
||||||
|
[args '()])
|
||||||
|
(cond
|
||||||
|
[(null? gens) (apply constructor args)]
|
||||||
|
[else (loop (cdr gens)
|
||||||
|
(cons ((car gens)) args))])))]
|
||||||
|
[else
|
||||||
|
(define subc (car subcs))
|
||||||
|
(cond
|
||||||
|
[(invariant? subc) #f]
|
||||||
|
[(indep? subc)
|
||||||
|
(define sgen (generate/choose (indep-ctc subc) fuel))
|
||||||
|
(cond
|
||||||
|
[sgen (loop (cdr subcs) (cons sgen gens))]
|
||||||
|
[else #f])]
|
||||||
|
[else #f])]))))
|
||||||
|
|
||||||
(define (struct/dc-first-order ctc)
|
(define (struct/dc-first-order ctc)
|
||||||
(base-struct/dc-pred ctc))
|
(base-struct/dc-pred ctc))
|
||||||
|
|
||||||
|
@ -641,7 +666,7 @@
|
||||||
#:when (invariant? sub))
|
#:when (invariant? sub))
|
||||||
sub))
|
sub))
|
||||||
|
|
||||||
(define-struct base-struct/dc (subcontracts pred struct-name here name-info struct/c?))
|
(define-struct base-struct/dc (subcontracts constructor pred struct-name here name-info struct/c?))
|
||||||
|
|
||||||
(define (struct/dc-exercise stct)
|
(define (struct/dc-exercise stct)
|
||||||
(λ (fuel)
|
(λ (fuel)
|
||||||
|
@ -662,6 +687,7 @@
|
||||||
#:first-order struct/dc-first-order
|
#:first-order struct/dc-first-order
|
||||||
#:projection struct/dc-proj
|
#:projection struct/dc-proj
|
||||||
#:stronger struct/dc-stronger?
|
#:stronger struct/dc-stronger?
|
||||||
|
#:generate struct/dc-generate
|
||||||
#:exercise struct/dc-exercise)))
|
#:exercise struct/dc-exercise)))
|
||||||
|
|
||||||
(define-struct (flat-struct/dc base-struct/dc) ()
|
(define-struct (flat-struct/dc base-struct/dc) ()
|
||||||
|
@ -672,6 +698,7 @@
|
||||||
#:first-order struct/dc-flat-first-order
|
#:first-order struct/dc-flat-first-order
|
||||||
#:projection struct/dc-proj
|
#:projection struct/dc-proj
|
||||||
#:stronger struct/dc-stronger?
|
#:stronger struct/dc-stronger?
|
||||||
|
#:generate struct/dc-generate
|
||||||
#:exercise struct/dc-exercise)))
|
#:exercise struct/dc-exercise)))
|
||||||
|
|
||||||
(define-struct (impersonator-struct/dc base-struct/dc) ()
|
(define-struct (impersonator-struct/dc base-struct/dc) ()
|
||||||
|
@ -682,9 +709,10 @@
|
||||||
#:first-order struct/dc-first-order
|
#:first-order struct/dc-first-order
|
||||||
#:projection struct/dc-proj
|
#:projection struct/dc-proj
|
||||||
#:stronger struct/dc-stronger?
|
#:stronger struct/dc-stronger?
|
||||||
|
#:generate struct/dc-generate
|
||||||
#:exercise struct/dc-exercise)))
|
#:exercise struct/dc-exercise)))
|
||||||
|
|
||||||
(define (build-struct/dc subcontracts pred struct-name here name-info struct/c?)
|
(define (build-struct/dc subcontracts constructor pred struct-name here name-info struct/c?)
|
||||||
(for ([subcontract (in-list subcontracts)])
|
(for ([subcontract (in-list subcontracts)])
|
||||||
(when (and (indep? subcontract)
|
(when (and (indep? subcontract)
|
||||||
(not (mutable? subcontract)))
|
(not (mutable? subcontract)))
|
||||||
|
@ -709,11 +737,11 @@
|
||||||
(cond
|
(cond
|
||||||
[(and (andmap flat-subcontract? subcontracts)
|
[(and (andmap flat-subcontract? subcontracts)
|
||||||
(not (ormap subcontract-mutable-field? subcontracts)))
|
(not (ormap subcontract-mutable-field? subcontracts)))
|
||||||
(make-flat-struct/dc subcontracts pred struct-name here name-info struct/c?)]
|
(make-flat-struct/dc subcontracts constructor pred struct-name here name-info struct/c?)]
|
||||||
[(ormap impersonator-subcontract? subcontracts)
|
[(ormap impersonator-subcontract? subcontracts)
|
||||||
(make-impersonator-struct/dc subcontracts pred struct-name here name-info struct/c?)]
|
(make-impersonator-struct/dc subcontracts constructor pred struct-name here name-info struct/c?)]
|
||||||
[else
|
[else
|
||||||
(make-struct/dc subcontracts pred struct-name here name-info struct/c?)]))
|
(make-struct/dc subcontracts constructor pred struct-name here name-info struct/c?)]))
|
||||||
|
|
||||||
|
|
||||||
(define-for-syntax (get-struct-info id stx)
|
(define-for-syntax (get-struct-info id stx)
|
||||||
|
@ -1190,6 +1218,7 @@
|
||||||
(cdr clauses)))])))
|
(cdr clauses)))])))
|
||||||
|
|
||||||
#`(build-struct/dc (list #,@structs)
|
#`(build-struct/dc (list #,@structs)
|
||||||
|
#,(list-ref info 1)
|
||||||
#,(list-ref info 2)
|
#,(list-ref info 2)
|
||||||
'#,struct-id
|
'#,struct-id
|
||||||
(quote-module-name)
|
(quote-module-name)
|
||||||
|
|
Loading…
Reference in New Issue
Block a user