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

fix first-order test for struct/dc contracts

Browse Source 
closes PR 13090
This commit is contained in:
Robby Findler 2012-09-19 15:41:24 -05:00
parent c16b696272
commit e6a25f65ca
2 changed files with 79 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
collects/racket/contract/private/struct-dc.rkt
View File

@ -128,6 +128,25 @@
(list (dep-type subcontract)))
...]]))))
(define (struct/dc-flat-first-order ctc)
(define struct-pred? (base-struct/dc-pred ctc))
(λ (v)
(and (struct-pred? v)
(let loop ([subcs (base-struct/dc-subcontracts ctc)]
[args '()])
(cond
[(null? subcs) #t]
[else
(define subc (car subcs))
(define val ((subcontract-ref subc) v))
(cond
[(indep? subc)
(and ((flat-contract-predicate (indep-ctc subc)) val)
(loop (cdr subcs) (cons val args)))]
[else
(and ((flat-contract-predicate (apply (dep-dep-proc subc) args)) val)
(loop (cdr subcs) (cons val args)))])])))))
(define (struct/dc-first-order ctc)
(base-struct/dc-pred ctc))
@ -426,7 +445,7 @@
(parameterize ([skip-projection-wrapper? #t])
(build-flat-contract-property
#:name struct/dc-name
#:first-order struct/dc-first-order
#:first-order struct/dc-flat-first-order
#:projection struct/dc-proj
#:stronger struct/dc-stronger?)))
@ -456,15 +475,14 @@
(cond
[(indep? subcontract) (impersonator-contract? (indep-ctc subcontract))]
[(dep? subcontract) (eq? '#:impersonator (dep-type subcontract))]))
((cond
[(and (andmap flat-subcontract? subcontracts)
(not (ormap subcontract-mutable-field? subcontracts)))
make-flat-struct/dc]
[(ormap impersonator-subcontract? subcontracts)
make-impersonator-struct/dc]
[else
make-struct/dc])
subcontracts pred struct-name here name-info struct/c?))
(cond
[(and (andmap flat-subcontract? subcontracts)
(not (ormap subcontract-mutable-field? subcontracts)))
(make-flat-struct/dc subcontracts pred struct-name here name-info struct/c?)]
[(ormap impersonator-subcontract? subcontracts)
(make-impersonator-struct/dc subcontracts pred struct-name here name-info struct/c?)]
[else
(make-struct/dc subcontracts pred struct-name here name-info struct/c?)]))
(define-for-syntax (get-struct-info id stx)

52
collects/tests/racket/contract-test.rktl
View File

@ -9467,7 +9467,15 @@
'pos
'neg)))
22)
(test/spec-passed/result
'struct/c16
'(let ()
(struct doll (contents))
(list ((flat-contract-predicate (struct/c doll 'center)) (doll 'center))
((flat-contract-predicate (struct/c doll 'center)) (doll 'not-center-center))))
'(#t #f))
;
;
@ -10227,6 +10235,34 @@
'neg)))
#\a)
(test/spec-passed/result
'struct/dc-pred1
'(let ()
(struct s (a b))
(define p? (flat-contract-predicate (struct/dc s [a number?] [b (a) #:flat (<=/c a)])))
(list (p? (s 2 1))
(p? (s 1 2))))
'(#t #f))
(test/spec-passed/result
'struct/dc-pred2
'(let ()
(struct s (a b c))
(define p? (flat-contract-predicate (struct/dc s
[a number?]
[b boolean?]
[c (a b)
#:flat
(if (and (= a 1) b)
any/c
none/c)])))
(list (p? (s 1 #t 'whatever))
(p? (s 11 #f 'whatver))))
'(#t #f))
(contract-error-test
'struct/dc-imp-nondep-runtime-error
#'(let ()
@ -10366,6 +10402,20 @@
'recursive-contract9
'(letrec ([ctc (or/c number? (hash/c (recursive-contract ctc #:chaperone) number?))])
(make-hash (list (cons (make-hash (list (cons 3 4))) 5)))))
(test/pos-blame
'recursive-contract10
'(let ()
(struct doll (contents))
(letrec ([doll-ctc (recursive-contract (or/c 'center (struct/c doll doll-ctc)) #:flat)])
(contract doll-ctc (doll 3) 'pos 'neg))))
(test/pos-blame
'recursive-contract11
'(let ()
(struct doll (contents))
(letrec ([doll-ctc2 (or/c 'center (struct/c doll (recursive-contract doll-ctc2 #:flat)))])
(contract doll-ctc2 (doll 4) 'pos 'neg))))