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

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

@ -629,33 +629,39 @@
(define/subexpression-pos-prop (cons/c a b) (cons/c-main-function a b)) (define/subexpression-pos-prop (cons/c a b) (cons/c-main-function a b))
(define/subexpression-pos-prop (list/c . args) (define/subexpression-pos-prop (list/c . args)
(let* ([args (coerce-contracts 'list/c args)]) (define ctc-args (coerce-contracts 'list/c args))
(if (andmap flat-contract? args) (cond
(flat-list/c args) [(andmap flat-contract? ctc-args)
(higher-order-list/c 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] (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 generic-list/c (args))
(struct flat-list/c generic-list/c ()
#:property prop:flat-contract #:property prop:flat-contract
(build-flat-contract-property (build-flat-contract-property
#:name #:name list/c-name-proc
(lambda (c) #:first-order list/c-first-order
(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 #:projection
(lambda (c) (lambda (c)
(lambda (b) (lambda (b)
(lambda (x) (lambda (x)
(unless (list? x) (unless (list? x)
(raise-blame-error b x "expected a list, got: ~e" x)) (raise-blame-error b x "expected a list, got: ~e" x))
(let* ([args (flat-list/c-args c)] (let* ([args (generic-list/c-args c)]
[expected (length args)] [expected (length args)]
[actual (length x)]) [actual (length x)])
(unless (= actual expected) (unless (= actual expected)
@ -667,37 +673,38 @@
(((contract-projection arg/c) b) v)) (((contract-projection arg/c) b) v))
x)))))) x))))))
(struct higher-order-list/c [args] (define (list/c-chaperone/other-projection c)
#:property prop:contract (define args (map contract-projection (generic-list/c-args c)))
(build-contract-property (define expected (length args))
#:name (λ (b)
(lambda (c) (define projs (for/list ([arg/c (in-list args)])
(apply build-compound-type-name (arg/c b)))
'list/c (higher-order-list/c-args c))) (λ (x)
#: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) (unless (list? x)
(raise-blame-error b x "expected a list, got: ~e" x)) (raise-blame-error b x "expected a list, got: ~e" x))
(let* ([args (higher-order-list/c-args c)] (define actual (length x))
[expected (length args)]
[actual (length x)])
(unless (= actual expected) (unless (= actual expected)
(raise-blame-error (raise-blame-error
b x b x
"expected a list of ~a elements, but got ~a elements in: ~e" "expected a list of ~a elements, but got ~a elements in: ~e"
expected actual x)) expected actual x))
(for/list ([arg/c (in-list args)] [v (in-list x)]) (for/list ([item (in-list x)]
(((contract-projection arg/c) b) v)))))))) [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) (define/subexpression-pos-prop (syntax/c ctc-in)
(let ([ctc (coerce-contract '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 #f flat-contract? (set/c (-> integer? integer?)))
(ctest #t chaperone-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. ;; Make sure that impersonators cannot be used as the element contract in set/c.
(contract-error-test (contract-error-test
'contract-error-test-set 'contract-error-test-set