diff --git a/collects/tests/unstable/contract.rkt b/collects/tests/unstable/contract.rkt index 82ab3fc790..ecffc475bc 100644 --- a/collects/tests/unstable/contract.rkt +++ b/collects/tests/unstable/contract.rkt @@ -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?))) diff --git a/collects/unstable/contract.rkt b/collects/unstable/contract.rkt index aa307d65cd..85ff504491 100644 --- a/collects/unstable/contract.rkt +++ b/collects/unstable/contract.rkt @@ -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?)]) diff --git a/collects/unstable/scribblings/contract.scrbl b/collects/unstable/scribblings/contract.scrbl index 9fd76850cc..b525bd8489 100644 --- a/collects/unstable/scribblings/contract.scrbl +++ b/collects/unstable/scribblings/contract.scrbl @@ -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)) ] }