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

Update to modern contract combinators.

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2012-07-17 17:10:51 -04:00
parent 857a312e61
commit df8e109c6a
1 changed files with 36 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
collects/unstable/contract.rkt
View File

@ -1,5 +1,5 @@
#lang racket/base #lang racket/base
(require racket/contract racket/dict racket/match) (require racket/contract/base racket/contract/combinator)
(define path-piece? (define path-piece?
(or/c path-string? (symbols 'up 'same))) (or/c path-string? (symbols 'up 'same)))
@ -137,39 +137,44 @@
(let* ([elem/cs (for/list ([elem/c (in-list elem/cs)]) (let* ([elem/cs (for/list ([elem/c (in-list elem/cs)])
(coerce-contract 'sequence/c elem/c))] (coerce-contract 'sequence/c elem/c))]
[n-cs (length elem/cs)]) [n-cs (length elem/cs)])
(make-proj-contract (make-contract
(apply build-compound-type-name 'sequence/c elem/cs) #:name (apply build-compound-type-name 'sequence/c elem/cs)
(lambda (pos neg src name blame) #:first-order sequence?
(lambda (seq) #:projection
(λ (blame)
(λ (seq)
(define pos (blame-positive blame))
(define neg (blame-negative blame))
(define src (list (blame-source blame) (blame-value blame)))
(define name (blame-contract blame))
(unless (sequence? seq) (unless (sequence? seq)
(raise-contract-error (raise-blame-error
seq src pos name blame seq
"expected a sequence, got: ~e" "expected a sequence, got: ~e"
seq)) seq))
(make-do-sequence (make-do-sequence
(lambda () (lambda ()
(let*-values ([(more? next) (sequence-generate seq)]) (let*-values ([(more? next) (sequence-generate seq)])
(values (values
(lambda (idx) (lambda (idx)
(call-with-values next (call-with-values next
(lambda elems (lambda elems
(define n-elems (length elems)) (define n-elems (length elems))
(unless (= n-elems n-cs) (unless (= n-elems n-cs)
(raise-contract-error (raise-blame-error
seq src pos name blame seq
"expected a sequence of ~a values, got ~a values: ~s" "expected a sequence of ~a values, got ~a values: ~s"
n-cs n-elems elems)) n-cs n-elems elems))
(apply (apply
values values
(for/list ([elem (in-list elems)] (for/list ([elem (in-list elems)]
[elem/c (in-list elem/cs)]) [elem/c (in-list elem/cs)])
(((contract-proc elem/c) pos neg src name blame) elem)))))) (((contract-projection elem/c) blame) elem))))))
(lambda (idx) idx) (lambda (idx) idx)
#f #f
(lambda (idx) (more?)) (lambda (idx) (more?))
(lambda elems #t) (lambda elems #t)
(lambda (idx . elems) #t))))))) (lambda (idx . elems) #t))))))))))
sequence?)))
;; Added by ntoronto ;; Added by ntoronto