sequence/c changes
- build the sub projections only once and build them before getting the blame objects (instead of after getting the actual values) - added context information to the blame objects - added an optional #:min-count argument to insist on a minimum length for the stream related to PR 13709
This commit is contained in:
Robby Findler
parent
e6ff57f3bd
commit
ec2d57bf80
|
|
@ -36,7 +36,12 @@
|
|||
(test-bad
|
||||
(for ([(x y) (with/c (sequence/c integer?)
|
||||
(in-dict (list (cons 1 'one) (cons 2 'two))))])
|
||||
(void)))))
|
||||
(void)))
|
||||
(let ([s (sequence->stream (contract (sequence/c #:min-count 2 any/c) "x" 'pos 'neg))])
|
||||
(check-equal? (stream-first s) #\x)
|
||||
(check-exn (λ (x) (and (exn:fail? x)
|
||||
(regexp-match #rx"blaming: pos" (exn-message x))))
|
||||
(lambda () (stream-first (stream-rest s)))))))
|
||||
(test-suite "Data structure contracts"
|
||||
(test-suite "maybe/c"
|
||||
(test-true "flat" (flat-contract? (maybe/c number?)))
|
||||
|
|
|
|||
|
|
@ -133,48 +133,65 @@
|
|||
;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (sequence/c . elem/cs)
|
||||
(let* ([elem/cs (for/list ([elem/c (in-list elem/cs)])
|
||||
(coerce-contract 'sequence/c elem/c))]
|
||||
[n-cs (length elem/cs)])
|
||||
(make-contract
|
||||
#:name (apply build-compound-type-name 'sequence/c elem/cs)
|
||||
#:first-order sequence?
|
||||
#: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)
|
||||
(raise-blame-error
|
||||
blame seq
|
||||
'(expected: "a sequence" given: "~e")
|
||||
seq))
|
||||
(make-do-sequence
|
||||
(lambda ()
|
||||
(let*-values ([(more? next) (sequence-generate seq)])
|
||||
(values
|
||||
(lambda (idx)
|
||||
(call-with-values next
|
||||
(lambda elems
|
||||
(define n-elems (length elems))
|
||||
(unless (= n-elems n-cs)
|
||||
(raise-blame-error
|
||||
blame seq
|
||||
'(expected: "a sequence of ~a values" given: "~a values\n values: ~e")
|
||||
n-cs n-elems elems))
|
||||
(apply
|
||||
values
|
||||
(for/list ([elem (in-list elems)]
|
||||
[elem/c (in-list elem/cs)])
|
||||
(((contract-projection elem/c) blame) elem))))))
|
||||
(lambda (idx) idx)
|
||||
#f
|
||||
(lambda (idx) (more?))
|
||||
(lambda elems #t)
|
||||
(lambda (idx . elems) #t))))))))))
|
||||
(define (sequence/c #:min-count [min-count #f] . elem/cs)
|
||||
(define ctcs (for/list ([elem/c (in-list elem/cs)])
|
||||
(coerce-contract 'sequence/c elem/c)))
|
||||
(define elem/mk-projs
|
||||
(for/list ([ctc (in-list ctcs)])
|
||||
(contract-projection ctc)))
|
||||
(define n-cs (length elem/cs))
|
||||
(make-contract
|
||||
#:name (apply build-compound-type-name 'sequence/c
|
||||
(append
|
||||
(if min-count
|
||||
(list '#:min-count min-count)
|
||||
'())
|
||||
ctcs))
|
||||
#:first-order sequence?
|
||||
#:projection
|
||||
(λ (orig-blame)
|
||||
(define blame (blame-add-context orig-blame "an element of"))
|
||||
(define ps (for/list ([mk-proj (in-list elem/mk-projs)])
|
||||
(mk-proj blame)))
|
||||
(λ (seq)
|
||||
(unless (sequence? seq)
|
||||
(raise-blame-error
|
||||
orig-blame seq
|
||||
'(expected: "a sequence" given: "~e")
|
||||
seq))
|
||||
(make-do-sequence
|
||||
(lambda ()
|
||||
(let*-values ([(more? next) (sequence-generate seq)])
|
||||
(values
|
||||
(lambda (idx)
|
||||
(call-with-values next
|
||||
(lambda elems
|
||||
(define n-elems (length elems))
|
||||
(unless (= n-elems n-cs)
|
||||
(raise-blame-error
|
||||
blame seq
|
||||
'(expected: "a sequence of ~a values" given: "~a values\n values: ~e")
|
||||
n-cs n-elems elems))
|
||||
(apply
|
||||
values
|
||||
(for/list ([elem (in-list elems)]
|
||||
[p (in-list ps)])
|
||||
(p elem))))))
|
||||
add1
|
||||
0
|
||||
(lambda (idx)
|
||||
(define ans (more?))
|
||||
(when (and min-count (idx . < . min-count))
|
||||
(unless ans
|
||||
(raise-blame-error
|
||||
orig-blame
|
||||
seq
|
||||
'(expected: "a sequence that contains at least ~a values" given: "~e")
|
||||
min-count
|
||||
seq)))
|
||||
ans)
|
||||
(lambda elems #t)
|
||||
(lambda (idx . elems) #t)))))))))
|
||||
|
||||
;; Added by ntoronto
|
||||
|
||||
|
|
@ -202,8 +219,10 @@
|
|||
|
||||
[truth/c flat-contract?]
|
||||
|
||||
[sequence/c (->* [] [] #:rest (listof contract?) contract?)]
|
||||
[sequence/c (->* ()
|
||||
(#:min-count (or/c #f exact-nonnegative-integer?))
|
||||
#:rest (listof contract?)
|
||||
contract?)]
|
||||
|
||||
[treeof (contract? . -> . contract?)]
|
||||
)
|
||||
[treeof (contract? . -> . contract?)])
|
||||
|
||||
|
|
|
|||
|
|
@ -89,7 +89,9 @@ that accept arbitrary truth values that may not be booleans.
|
|||
|
||||
}
|
||||
|
||||
@defproc[(sequence/c [elem/c contract?] ...) contract?]{
|
||||
@defproc[(sequence/c [#:min-count min-count (or/c #f exact-nonnegative-integer?) #f]
|
||||
[elem/c contract?] ...)
|
||||
contract?]{
|
||||
|
||||
Wraps a @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{sequence},
|
||||
obligating it to produce as many values as there are @racket[elem/c] contracts,
|
||||
|
|
@ -97,6 +99,8 @@ and obligating each value to satisfy the corresponding @racket[elem/c]. The
|
|||
result is not guaranteed to be the same kind of sequence as the original value;
|
||||
for instance, a wrapped list is not guaranteed to satisfy @racket[list?].
|
||||
|
||||
If @racket[min-count] is a number, the stream is required to have at least that many elements in it.
|
||||
|
||||
@defexamples[
|
||||
#:eval the-eval
|
||||
(define/contract predicates
|
||||
|
|
@ -112,6 +116,12 @@ for instance, a wrapped list is not guaranteed to satisfy @racket[list?].
|
|||
(cons 3 'three))))
|
||||
(for ([(N S) numbers&strings])
|
||||
(printf "~s: ~a\n" N S))
|
||||
(define/contract a-sequence
|
||||
(sequence/c #:min-count 2 char?)
|
||||
"x")
|
||||
(for ([x a-sequence]
|
||||
[i (in-naturals)])
|
||||
(printf "~a is ~a\n" i x))
|
||||
]
|
||||
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user