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

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?)))

collects/unstable/contract.rkt

@@ -133,48 +133,65 @@
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define (sequence/c . elem/cs)
+(define (sequence/c #:min-count [min-count #f] . elem/cs)
-  (let* ([elem/cs (for/list ([elem/c (in-list elem/cs)])
+  (define ctcs (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)])
+  (define elem/mk-projs 
-    (make-contract
+    (for/list ([ctc (in-list ctcs)])
-     #:name (apply build-compound-type-name 'sequence/c elem/cs)
+      (contract-projection ctc)))
-     #:first-order sequence?
+  (define n-cs (length elem/cs))
-     #:projection
+  (make-contract
-     (λ (blame)       
+   #:name (apply build-compound-type-name 'sequence/c 
-       (λ (seq)
+                 (append
-         (define pos (blame-positive blame))
+                  (if min-count
-         (define neg (blame-negative blame))
+                      (list '#:min-count min-count)
-         (define src (list (blame-source blame) (blame-value blame)))
+                      '())
-         (define name (blame-contract blame))
+                  ctcs))
-         (unless (sequence? seq)
+   #:first-order sequence?
-           (raise-blame-error
+   #:projection
-            blame seq
+   (λ (orig-blame)
-            '(expected: "a sequence" given: "~e")
+     (define blame (blame-add-context orig-blame "an element of"))
-            seq))
+     (define ps (for/list ([mk-proj (in-list elem/mk-projs)])
-         (make-do-sequence
+                  (mk-proj blame)))
-          (lambda ()
+     (λ (seq)
-            (let*-values ([(more? next) (sequence-generate seq)])
+       (unless (sequence? seq)
-              (values
+         (raise-blame-error
-               (lambda (idx)
+          orig-blame seq
-                 (call-with-values next
+          '(expected: "a sequence" given: "~e")
-                                   (lambda elems
+          seq))
-                                     (define n-elems (length elems))
+       (make-do-sequence
-                                     (unless (= n-elems n-cs)
+        (lambda ()
-                                       (raise-blame-error
+          (let*-values ([(more? next) (sequence-generate seq)])
-                                        blame seq
+            (values
-                                        '(expected: "a sequence of ~a values" given: "~a values\n values: ~e")
+             (lambda (idx)
-                                        n-cs n-elems elems))
+               (call-with-values next
-                                     (apply
+                                 (lambda elems
-                                      values
+                                   (define n-elems (length elems))
-                                      (for/list ([elem (in-list elems)]
+                                   (unless (= n-elems n-cs)
-                                                 [elem/c (in-list elem/cs)])
+                                     (raise-blame-error
-                                        (((contract-projection elem/c) blame) elem))))))
+                                      blame seq
-               (lambda (idx) idx)
+                                      '(expected: "a sequence of ~a values" given: "~a values\n values: ~e")
-               #f
+                                      n-cs n-elems elems))
-               (lambda (idx) (more?))
+                                   (apply
-               (lambda elems #t)
+                                    values
-               (lambda (idx . elems) #t))))))))))
+                                    (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?)])
- )
 

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))
 ]
 
 }