add *list/c

pkgs/racket-doc/scribblings/reference/contracts.scrbl

@@ -552,6 +552,29 @@ each element of the list must match the corresponding contract. Beware
 that when this contract is applied to a value, the result is not
 necessarily @racket[eq?] to the input.}
 
+@defproc[(*list/c [prefix contract?] [suffix contract?] ...) list-contract?]{
+
+Produces a contract for a list. The number of elements in the list
+must be at least as long as the number of @racket[suffix] contracts
+and the tail of the list must match those contracts, one for each
+element. The beginning portion of the list can be arbitrarily long,
+and each element must match @racket[prefix].
+
+Beware that when this contract is applied to a value, the result is not
+necessarily @racket[eq?] to the input.
+
+ @examples[#:eval (contract-eval) #:once
+           (define/contract a-list-of-numbers-ending-with-two-integers
+             (*list/c number? integer? integer?)
+             (list 1/2 4/5 +1i -11 322))
+           
+           (eval:error
+            (define/contract not-enough-integers-at-the-end
+              (*list/c number? integer? integer? integer?)
+              (list 1/2 4/5 1/2 321 322)))]
+
+}
+
 
 @defproc[(syntax/c [c flat-contract?]) flat-contract?]{
 

pkgs/racket-test/tests/racket/contract/first-order.rkt

@@ -58,6 +58,12 @@
   (ctest #t contract-first-order-passes? (non-empty-listof integer?) (list 1))
   (ctest #f contract-first-order-passes? (non-empty-listof integer?) (list))
 
+  (ctest #t contract-first-order-passes? (*list/c integer? boolean? char?) '(1 2 3 4 #f #\a))
+  (ctest #t contract-first-order-passes? (*list/c integer? boolean? char?) '(#f #\a))
+  (ctest #f contract-first-order-passes? (*list/c integer? boolean? char?) '(1 2 #f 4 #f #\a))
+  (ctest #f contract-first-order-passes? (*list/c integer? boolean? char?) '())
+  (ctest #f contract-first-order-passes? (*list/c integer? boolean? char?) '(#f))
+  (ctest #f contract-first-order-passes? (*list/c integer? boolean? char?) 1)
   
   (ctest #t contract-first-order-passes?
          (vector-immutableof integer?)

pkgs/racket-test/tests/racket/contract/list-contract.rkt

@@ -159,6 +159,18 @@
        c))
    #t)
 
+  (test/spec-passed/result
+   'list-contract-25
+   '(list-contract?
+     (*list/c integer? boolean? char?))
+   #t)
+
+  (test/spec-passed/result
+   'list-contract-26
+   '(list-contract?
+     (*list/c (-> integer? integer?) boolean? char?))
+   #t)
+  
   (test/pos-blame
    'test-contract-25
    '(contract (letrec ([c (recursive-contract (first-or/c (cons/c any/c c) empty?) 

pkgs/racket-test/tests/racket/contract/list.rkt

@@ -171,4 +171,39 @@
    '(contract? (cons/dc [hd integer?] [tl (hd) integer?] #:impersonator))
    #t)
 
+  (test/spec-passed/result
+   '*list/c1
+   '(contract (*list/c integer? char? boolean?) '(1 2 3 #\a #f) 'pos 'neg)
+   '(1 2 3 #\a #f))
+  (test/pos-blame
+   '*list/c2
+   '(contract (*list/c integer? char? boolean?) '(1 2 #\a #\a #f) 'pos 'neg))
+  (test/spec-passed/result
+   '*list/c3
+   '((car (contract (*list/c (-> integer? integer?) (-> boolean? boolean?))
+                    (list (λ (x) x) (λ (y) y)) 'pos 'neg))
+     1)
+   1)
+  (test/neg-blame
+   '*list/c4
+   '((car (contract (*list/c (-> integer? integer?) (-> boolean? boolean?))
+                    (list (λ (x) x) (λ (y) y)) 'pos 'neg))
+     #f))
+  (test/spec-passed/result
+   '*list/c5
+   '((cadr (contract (*list/c (-> integer? integer?) (-> boolean? boolean?))
+                     (list (λ (x) x) (λ (y) y)) 'pos 'neg))
+     #f)
+   #f)
+  (test/neg-blame
+   '*list/c6
+   '((cadr (contract (*list/c (-> integer? integer?) (-> boolean? boolean?))
+                     (list (λ (x) x) (λ (y) y)) 'pos 'neg))
+     1))
+  (test/pos-blame
+   '*list/c7
+   '((caddr (contract (*list/c (-> integer? integer?) (-> boolean? boolean?) (-> char? char?))
+                      (list (λ (x) x) (λ (y) y) (λ (y) 'not-a-bool) (λ (y) y)) 'pos 'neg))
+     #f))
+  
   )

pkgs/racket-test/tests/racket/contract/random-generate.rkt

@@ -79,6 +79,8 @@
 (check-not-exn (λ () (test-contract-generation (list*of boolean? char?))))
 (check-not-exn (λ () (test-contract-generation (list/c boolean? number?))))
 (check-not-exn (λ () ((car (test-contract-generation (list/c (-> number? number?)))) 0)))
+(check-not-exn (λ () (test-contract-generation (*list/c boolean? number? char?))))
+(check-not-exn (λ () (test-contract-generation (-> (*list/c boolean? number? char?) any))))
 
 (check-not-exn
  (λ ()

pkgs/racket-test/tests/racket/contract/stronger.rkt

@@ -305,6 +305,10 @@
   (ctest #t contract-stronger? (list/c (<=/c 3)) (non-empty-listof (<=/c 5)))
   (ctest #f contract-stronger? (list/c) (non-empty-listof (<=/c 5)))
   (ctest #t contract-stronger? (list/c) (listof (<=/c 5)))
+
+  (ctest #t contract-stronger? (*list/c integer? boolean? char?) (*list/c integer? boolean? char?))
+  (ctest #t contract-stronger? (list/c integer? boolean? char?) (listof (or/c integer? boolean? char?)))
+  
   (ctest #t contract-stronger? (promise/c (<=/c 2)) (promise/c (<=/c 3)))
   (ctest #f contract-stronger? (promise/c (<=/c 3)) (promise/c (<=/c 2)))
   

racket/collects/racket/contract/base.rkt

@@ -76,6 +76,7 @@
  false/c
  printable/c
  listof list*of non-empty-listof cons/c list/c cons/dc
+ *list/c
  promise/c
  syntax/c
  

racket/collects/racket/contract/private/list.rkt

@@ -14,7 +14,8 @@
 (provide listof list*of non-empty-listof cons/c list/c cons/dc
          blame-add-car-context
          blame-add-cdr-context
-         raise-not-cons-blame-error)
+         raise-not-cons-blame-error
+         *list/c)
 
 (define (listof-generate ctc)
   (cond
@@ -779,6 +780,197 @@
    #:late-neg-projection list/c-chaperone/other-late-neg-projection
    #:list-contract? (λ (c) #t)))
 
+(define (*list/c-name-proc ctc)
+  `(*list/c ,(contract-name (*list-ctc-prefix ctc))
+            ,@(map contract-name (*list-ctc-suffix ctc))))
+
+(define (*list/c-first-order ctc)
+  (define prefix? (contract-first-order (*list-ctc-prefix ctc)))
+  (define suffix?s (map contract-first-order (*list-ctc-suffix ctc)))
+  (define suffix?s-len (length suffix?s))
+  (λ (val)
+    (cond
+      [(list? val)
+       (define-values (long-enough? end) (get-end val suffix?s-len))
+       (cond
+         [long-enough?
+          (let loop ([val val]
+                     [end end])
+            (cond
+              [(null? end)
+               (for/and ([ele (in-list val)]
+                         [suffix? (in-list suffix?s)])
+                 (suffix? ele))]
+              [else
+               (and (prefix? (car val))
+                    (loop (cdr val) (cdr end)))]))]
+         [else #f])]
+      [else #f])))
+
+(define (get-end val suffix?s-len)
+  (let loop ([val val]
+             [i suffix?s-len])
+    (cond
+      [(zero? i) (values #t val)]
+      [(null? val) (values #f #f)]
+      [else (loop (cdr val) (- i 1))])))
+
+(define (*list/c-generate ctc)
+  (λ (fuel)
+    (define prefix-gen (contract-random-generate/choose (*list-ctc-prefix ctc) fuel))
+    (define suffix-gens
+      (for/list ([suf (*list-ctc-suffix ctc)])
+        (contract-random-generate/choose suf fuel)))
+    (and prefix-gen
+         (for/and ([i (in-list suffix-gens)]) i)
+         (λ ()
+           (let loop ()
+             (rand-choice
+              [1/5 (for/list ([suffix-gen (in-list suffix-gens)])
+                     (suffix-gen))]
+              [else (cons (prefix-gen) (loop))]))))))
+
+(define (*list/c-exercise ctc)
+  (define suffix (reverse (*list-ctc-suffix ctc)))
+  (λ (fuel)
+    (define env (contract-random-generate-get-current-environment))
+    (values
+     (λ (lst)
+       (let loop ([lst (reverse lst)]
+                  [suffix suffix])
+         (cond
+           [(null? suffix) (void)]
+           [else
+            (contract-random-generate-stash env (car lst) (car suffix))
+            (loop (cdr lst) (cdr suffix))])))
+     suffix)))
+
+(define (*list/c-stronger this that)
+  (define this-prefix (*list-ctc-prefix this))
+  (define this-suffix (*list-ctc-suffix this))
+  (cond
+    [(*list-ctc? that)
+     (define that-prefix (*list-ctc-prefix that))
+     (define that-suffix (*list-ctc-suffix that))
+     (define (pad-to a-suf b-suf a-prefix)
+       (define a-len (length a-suf))
+       (define b-len (length b-suf))
+       (cond
+         [(< a-len b-len)
+          (append (build-list (- b-len a-len) (λ (x) a-prefix))
+                  a-suf)]
+         [else a-suf]))
+     (define padded-this (pad-to this-suffix that-suffix this-prefix))
+     (define padded-that (pad-to that-suffix this-suffix that-prefix))
+     (and (contract-struct-stronger? this-prefix that-prefix)
+          (for/and ([this (in-list padded-this)]
+                    [that (in-list padded-that)])
+            (contract-struct-stronger? this that)))]
+    [(listof-ctc? that)
+     (define that-elem (listof-ctc-elem-c that))
+     (and (contract-struct-stronger? this-prefix that-elem)
+          (for/and ([suf (in-list this-suffix)])
+            (contract-struct-stronger? suf that-elem)))]
+    [else #f]))
+
+(define (*list/c-late-neg-projection ctc flat?)
+  (define prefix-lnp (contract-late-neg-projection (*list-ctc-prefix ctc)))
+  (define suffix-lnps (map contract-late-neg-projection (*list-ctc-suffix ctc)))
+  (define suffix?s-len (length suffix-lnps))
+  (λ (blame)
+    (define prefix-val-acceptor (prefix-lnp (blame-add-context blame "the prefix of")))
+    (define suffix-val-acceptors
+      (for/list ([i (in-naturals)]
+                 [suffix-lnp (in-list suffix-lnps)])
+        (define which (- suffix?s-len i))
+        (define msg
+          (if (= 1 which)
+              "the last element of"
+              (format "the ~a to the last element of" (n->th which))))
+        (suffix-lnp (blame-add-context blame msg))))
+    (λ (val neg-party)
+      (cond
+        [(list? val)
+         (define-values (long-enough? end) (get-end val suffix?s-len))
+         (cond
+           [long-enough?
+            (let loop ([remainder-to-process val]
+                       [end end])
+              (cond
+                [(null? end)
+                 (cond
+                   [flat?
+                    (for ([ele (in-list remainder-to-process)]
+                          [suffix-val-acceptor (in-list suffix-val-acceptors)])
+                      (suffix-val-acceptor ele neg-party))
+                    val]
+                   [else
+                    (for/list ([ele (in-list remainder-to-process)]
+                               [suffix-val-acceptor (in-list suffix-val-acceptors)])
+                      (suffix-val-acceptor ele neg-party))])]
+                [else
+                 (define fst (prefix-val-acceptor (car remainder-to-process) neg-party))
+                 (if flat?
+                     (loop (cdr remainder-to-process) (cdr end))
+                     (cons fst (loop (cdr remainder-to-process) (cdr end))))]))]
+           [else
+            (raise-blame-error
+             blame
+             val
+             '(expected: "list? with at least ~a elements" given: "~e")
+             suffix?s-len
+             val)])]
+        [else (raise-blame-error
+               blame
+               val
+               '(expected: "list?" given: "~e") val)]))))
+  
+;; prefix : contract
+;; suffix : (listof contract)
+(struct *list-ctc (prefix suffix)
+    #:property prop:custom-write custom-write-property-proc)
+
+(struct flat-*list/c *list-ctc ()
+  #:property prop:contract
+  (build-contract-property
+   #:name *list/c-name-proc
+   #:first-order *list/c-first-order
+   #:generate *list/c-generate
+   #:exercise *list/c-exercise
+   #:stronger *list/c-stronger
+   #:late-neg-projection (λ (ctc) (*list/c-late-neg-projection ctc #t))
+   #:list-contract? (λ (c) #t)))
+(struct chaperone-*list/c *list-ctc ()
+  #:property prop:contract
+  (build-contract-property
+   #:name *list/c-name-proc
+   #:first-order *list/c-first-order
+   #:generate *list/c-generate
+   #:exercise *list/c-exercise
+   #:stronger *list/c-stronger
+   #:late-neg-projection (λ (ctc) (*list/c-late-neg-projection ctc #f))
+   #:list-contract? (λ (c) #t)))
+(struct impersonator-*list/c *list-ctc ()
+  #:property prop:contract
+  (build-contract-property
+   #:name *list/c-name-proc
+   #:first-order *list/c-first-order
+   #:generate *list/c-generate
+   #:exercise *list/c-exercise
+   #:stronger *list/c-stronger
+   #:late-neg-projection (λ (ctc) (*list/c-late-neg-projection ctc #f))
+   #:list-contract? (λ (c) #t)))
+
+(define (*list/c ele . rest)
+  (define ctcs (coerce-contracts '*list/c (cons ele rest)))
+  (cond
+    [(null? rest) (listof ele)]
+    [(andmap flat-contract? ctcs)
+     (flat-*list/c (car ctcs) (cdr ctcs))]
+    [(andmap chaperone-contract? ctcs)
+     (chaperone-*list/c (car ctcs) (cdr ctcs))]
+    [else
+     (impersonator-*list/c (car ctcs) (cdr ctcs))]))
      
 ;; this is a hack to work around cyclic linking issues;
 ;; see definition of set-some-basic-contracts!