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 (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)
#:property prop:flat-contract (apply build-compound-type-name
(build-flat-contract-property 'list/c (generic-list/c-args c)))
#:name (define ((list/c-first-order c) x)
(lambda (c) (and (list? x)
(apply build-compound-type-name (= (length x) (length (generic-list/c-args c)))
'list/c (flat-list/c-args c))) (for/and ([arg/c (in-list (generic-list/c-args c))]
#:first-order [v (in-list x)])
(lambda (c) (arg/c v))))
(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))))))
(struct higher-order-list/c [args] (struct generic-list/c (args))
#:property prop:contract
(build-contract-property (struct flat-list/c generic-list/c ()
#:name #:property prop:flat-contract
(lambda (c) (build-flat-contract-property
(apply build-compound-type-name #:name list/c-name-proc
'list/c (higher-order-list/c-args c))) #:first-order list/c-first-order
#:first-order #:projection
(lambda (c) (lambda (c)
(lambda (x) (lambda (b)
(and (list? x) (lambda (x)
(= (length x) (length (higher-order-list/c-args c))) (unless (list? x)
(for/and ([arg/c (in-list (higher-order-list/c-args c))] (raise-blame-error b x "expected a list, got: ~e" x))
[v (in-list x)]) (let* ([args (generic-list/c-args c)]
(contract-first-order-passes? arg/c v))))) [expected (length args)]
#:projection [actual (length x)])
(lambda (c) (unless (= actual expected)
(lambda (b) (raise-blame-error
(lambda (x) b x
(unless (list? x) "expected a list of ~a elements, but got ~a elements in: ~e"
(raise-blame-error b x "expected a list, got: ~e" x)) expected actual x))
(let* ([args (higher-order-list/c-args c)] (for ([arg/c (in-list args)] [v (in-list x)])
[expected (length args)] (((contract-projection arg/c) b) v))
[actual (length x)]) x))))))
(unless (= actual expected)
(raise-blame-error (define (list/c-chaperone/other-projection c)
b x (define args (map contract-projection (generic-list/c-args c)))
"expected a list of ~a elements, but got ~a elements in: ~e" (define expected (length args))
expected actual x)) (λ (b)
(for/list ([arg/c (in-list args)] [v (in-list x)]) (define projs (for/list ([arg/c (in-list args)])
(((contract-projection arg/c) b) v)))))))) (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) (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