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

make list/c produce chaperone contracts, as appropriate

Browse Source 
closes PR 12319
This commit is contained in:
Robby Findler 2011-10-24 08:13:02 -05:00
parent a1654f1532
commit fb02a0a5cd
2 changed files with 77 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -629,75 +629,82 @@
(define/subexpression-pos-prop (cons/c a b) (cons/c-main-function a b))
(define/subexpression-pos-prop (list/c . args)
(let* ([args (coerce-contracts 'list/c args)])
(if (andmap flat-contract? args)
(flat-list/c args)
(higher-order-list/c args))))
(define ctc-args (coerce-contracts 'list/c args))
(cond
[(andmap flat-contract? ctc-args)
(flat-list/c ctc-args)]
[(andmap chaperone-contract? ctc-args)
(chaperone-list/c ctc-args)]
[else
(higher-order-list/c ctc-args)]))
(struct flat-list/c [args]
#:property prop:flat-contract
(build-flat-contract-property
#:name
(lambda (c)
(apply build-compound-type-name
'list/c (flat-list/c-args c)))
#:first-order
(lambda (c)
(lambda (x)
(and (list? x)
(= (length x) (length (flat-list/c-args c)))
(for/and ([arg/c (in-list (flat-list/c-args c))]
[v (in-list x)])
(arg/c v)))))
#:projection
(lambda (c)
(lambda (b)
(lambda (x)
(unless (list? x)
(raise-blame-error b x "expected a list, got: ~e" x))
(let* ([args (flat-list/c-args c)]
[expected (length args)]
[actual (length x)])
(unless (= actual expected)
(raise-blame-error
b x
"expected a list of ~a elements, but got ~a elements in: ~e"
expected actual x))
(for ([arg/c (in-list args)] [v (in-list x)])
(((contract-projection arg/c) b) v))
x))))))
(define (list/c-name-proc c)
(apply build-compound-type-name
'list/c (generic-list/c-args c)))
(define ((list/c-first-order c) x)
(and (list? x)
(= (length x) (length (generic-list/c-args c)))
(for/and ([arg/c (in-list (generic-list/c-args c))]
[v (in-list x)])
(arg/c v))))
(struct higher-order-list/c [args]
#:property prop:contract
(build-contract-property
#:name
(lambda (c)
(apply build-compound-type-name
'list/c (higher-order-list/c-args c)))
#:first-order
(lambda (c)
(lambda (x)
(and (list? x)
(= (length x) (length (higher-order-list/c-args c)))
(for/and ([arg/c (in-list (higher-order-list/c-args c))]
[v (in-list x)])
(contract-first-order-passes? arg/c v)))))
#:projection
(lambda (c)
(lambda (b)
(lambda (x)
(unless (list? x)
(raise-blame-error b x "expected a list, got: ~e" x))
(let* ([args (higher-order-list/c-args c)]
[expected (length args)]
[actual (length x)])
(unless (= actual expected)
(raise-blame-error
b x
"expected a list of ~a elements, but got ~a elements in: ~e"
expected actual x))
(for/list ([arg/c (in-list args)] [v (in-list x)])
(((contract-projection arg/c) b) v))))))))
(struct generic-list/c (args))
(struct flat-list/c generic-list/c ()
#:property prop:flat-contract
(build-flat-contract-property
#:name list/c-name-proc
#:first-order list/c-first-order
#:projection
(lambda (c)
(lambda (b)
(lambda (x)
(unless (list? x)
(raise-blame-error b x "expected a list, got: ~e" x))
(let* ([args (generic-list/c-args c)]
[expected (length args)]
[actual (length x)])
(unless (= actual expected)
(raise-blame-error
b x
"expected a list of ~a elements, but got ~a elements in: ~e"
expected actual x))
(for ([arg/c (in-list args)] [v (in-list x)])
(((contract-projection arg/c) b) v))
x))))))
(define (list/c-chaperone/other-projection c)
(define args (map contract-projection (generic-list/c-args c)))
(define expected (length args))
(λ (b)
(define projs (for/list ([arg/c (in-list args)])
(arg/c b)))
(λ (x)
(unless (list? x)
(raise-blame-error b x "expected a list, got: ~e" x))
(define actual (length x))
(unless (= actual expected)
(raise-blame-error
b x
"expected a list of ~a elements, but got ~a elements in: ~e"
expected actual x))
(for/list ([item (in-list x)]
[proj (in-list projs)])
(proj item)))))
(struct chaperone-list/c generic-list/c ()
#:property prop:chaperone-contract
(build-chaperone-contract-property
#:name list/c-name-proc
#:first-order list/c-first-order
#:projection list/c-chaperone/other-projection))
(struct higher-order-list/c generic-list/c ()
#:property prop:contract
(build-contract-property
#:name list/c-name-proc
#:first-order list/c-first-order
#:projection list/c-chaperone/other-projection))
(define/subexpression-pos-prop (syntax/c ctc-in)
(let ([ctc (coerce-contract 'syntax/c ctc-in)])

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

@ -9460,6 +9460,9 @@ so that propagation occurs.
(ctest #f flat-contract? (set/c (-> integer? integer?)))
(ctest #t chaperone-contract? (set/c (-> integer? integer?)))
(ctest #t flat-contract? (list/c integer?))
(ctest #t chaperone-contract? (list/c (-> integer? integer?)))
;; Make sure that impersonators cannot be used as the element contract in set/c.
(contract-error-test
'contract-error-test-set