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

Adjusted list/c to stand alone, rather than using cons/c, so that it prints as itself.

Browse Source
This commit is contained in:
Carl Eastlund 2010-05-10 16:39:07 -04:00
parent 15107e84c7
commit ff5b8da551
3 changed files with 81 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -990,10 +990,75 @@
[(_ hdp tlp) (opt/cons-ctc #'hdp #'tlp)]))
(define (list/c . args)
(let loop ([args (coerce-contracts 'list/c args)])
(cond
[(null? args) (flat-contract null?)]
[else (cons/c (car args) (loop (cdr args)))])))
(let* ([args (coerce-contracts 'list/c args)])
(if (andmap flat-contract? args)
(flat-list/c args)
(higher-order-list/c 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))))))
(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))))))))
(define (syntax/c ctc-in)
(let ([ctc (coerce-contract 'syntax/c ctc-in)])

12
collects/tests/racket/contract-mzlib-test.rktl
View File

@ -4201,21 +4201,21 @@ so that propagation occurs.
(test-name '(cons/c boolean? integer?) (cons/c boolean? (flat-contract integer?)))
(test-name '(cons/c boolean? integer?) (cons/c boolean? (flat-contract integer?)))
(test-name '(cons/c boolean? (cons/c integer? null?)) (list/c boolean? (flat-contract integer?)))
(test-name '(cons/c boolean? (cons/c integer? null?)) (list/c boolean? (flat-contract integer?)))
(test-name '(list/c boolean? integer?) (list/c boolean? (flat-contract integer?)))
(test-name '(list/c boolean? integer?) (list/c boolean? (flat-contract integer?)))
(test-name '(cons/c boolean? integer?) (cons/c boolean? (flat-contract integer?)))
(test-name '(cons/c boolean? integer?) (cons/c boolean? (flat-contract integer?)))
(test-name '(cons/c boolean? integer?) (cons/c boolean? (flat-contract integer?)))
(test-name '(cons/c (-> boolean? boolean?) integer?) (cons/c (-> boolean? boolean?) integer?))
(test-name '(cons/c boolean? (cons/c integer? null?))
(test-name '(list/c boolean? integer?)
(list/c boolean? (flat-contract integer?)))
(test-name '(cons/c boolean? (cons/c integer? null?))
(test-name '(list/c boolean? integer?)
(list/c boolean? (flat-contract integer?)))
(test-name '(cons/c boolean? (cons/c integer? null?))
(test-name '(list/c boolean? integer?)
(list/c boolean? (flat-contract integer?)))
(test-name '(cons/c (-> boolean? boolean?) (cons/c integer? null?))
(test-name '(list/c (-> boolean? boolean?) integer?)
(list/c (-> boolean? boolean?) integer?))
(test-name '(parameter/c integer?) (parameter/c integer?))

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

@ -7297,21 +7297,21 @@ so that propagation occurs.
(test-name '(cons/c boolean? integer?) (cons/c boolean? (flat-contract integer?)))
(test-name '(cons/c boolean? integer?) (cons/c boolean? (flat-contract integer?)))
(test-name '(cons/c boolean? (cons/c integer? null?)) (list/c boolean? (flat-contract integer?)))
(test-name '(cons/c boolean? (cons/c integer? null?)) (list/c boolean? (flat-contract integer?)))
(test-name '(list/c boolean? integer?) (list/c boolean? (flat-contract integer?)))
(test-name '(list/c boolean? integer?) (list/c boolean? (flat-contract integer?)))
(test-name '(cons/c boolean? integer?) (cons/c boolean? (flat-contract integer?)))
(test-name '(cons/c boolean? integer?) (cons/c boolean? (flat-contract integer?)))
(test-name '(cons/c boolean? integer?) (cons/c boolean? (flat-contract integer?)))
(test-name '(cons/c (-> boolean? boolean?) integer?) (cons/c (-> boolean? boolean?) integer?))
(test-name '(cons/c boolean? (cons/c integer? null?))
(test-name '(list/c boolean? integer?)
(list/c boolean? (flat-contract integer?)))
(test-name '(cons/c boolean? (cons/c integer? null?))
(test-name '(list/c boolean? integer?)
(list/c boolean? (flat-contract integer?)))
(test-name '(cons/c boolean? (cons/c integer? null?))
(test-name '(list/c boolean? integer?)
(list/c boolean? (flat-contract integer?)))
(test-name '(cons/c (-> boolean? boolean?) (cons/c integer? null?))
(test-name '(list/c (-> boolean? boolean?) integer?)
(list/c (-> boolean? boolean?) integer?))
(test-name '(parameter/c integer?) (parameter/c integer?))