add support for ... to -> contracts to indicate repeated arguments

also fix order of evaluation for ->

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

@@ -1011,13 +1011,18 @@ designed to match @racket[case-lambda] and
 without requiring that the domain have any particular shape
 (see below for an example use).
 
-@defform*/subs[#:literals (any values)
+@(define lit-ellipsis (racket ...))
-               [(-> dom ... range)]
-               ([dom dom-expr (code:line keyword dom-expr)]
-                [range range-expr (values range-expr ...) any])]{
 
-Produces a contract for a function that accepts a fixed
+@defform*/subs[#:literals (any values)
-number of arguments and returns either a fixed number of
+               [(-> dom ... range)
+                (-> dom ... ellipsis dom-expr ... range)]
+               ([dom dom-expr (code:line keyword dom-expr)]
+                [range range-expr (values range-expr ...) any]
+                [ellipsis #,lit-ellipsis])]{
+
+Produces a contract for a function that accepts the argument
+specified by the @racket[dom-expr] contracts and returns
+either a fixed number of
 results or completely unspecified results (the latter when
 @racket[any] is specified).
 
@@ -1025,6 +1030,13 @@ Each @racket[dom-expr] is a contract on an argument to a
 function, and each @racket[range-expr] is a contract on a
 result of the function.
 
+If the domain contain @racket[...]
+then the function accepts as many arguments as the rest of
+the contracts in the domain portion specify, as well as
+arbitrarily many more that match the contract just before the
+@racket[...]. Otherwise, the contract accepts exactly the
+argument specified.
+
 @margin-note{Using a @racket[->] between two whitespace-delimited
 @racketparenfont{.}s is the same as putting the @racket[->] right
 after the enclosing opening parenthesis. See
@@ -1032,9 +1044,7 @@ after the enclosing opening parenthesis. See
 information.}
 
 For example,
-
 @racketblock[(integer? boolean? . -> . integer?)]
-
 produces a contract on functions of two arguments. The first argument
 must be an integer, and the second argument must be a boolean. The
 function must produce an integer.
@@ -1043,12 +1053,16 @@ A domain specification may include a keyword. If so, the function must
 accept corresponding (mandatory) keyword arguments, and the values for
 the keyword arguments must match the corresponding contracts. For
 example:
-
 @racketblock[(integer? #:x boolean? . -> . integer?)]
-
 is a contract on a function that accepts a by-position argument that
 is an integer and a @racket[#:x] argument that is a boolean.
 
+As an example that uses an @racket[...], this contract:
+@racketblock[(integer? string? ... integer? . -> . any)]
+on a function insists that the first and last arguments to
+the function must be integers (and there must be at least
+two arguments) and any other arguments must be strings.
+
 If @racket[any] is used as the last sub-form for @racket[->], no
 contract checking is performed on the result of the function, and
 thus any number of values is legal (even different numbers on different

pkgs/racket-doc/scribblings/reference/stx-patterns.scrbl

@@ -501,8 +501,9 @@ but with syntax errors potentially phrased in terms of
 
 The @racket[...] transformer binding prohibits @racket[...] from
 being used as an expression. This binding is useful only in syntax
-patterns and templates, where it indicates repetitions of a pattern or
+patterns and templates (or other unrelated expression forms
-template. See @racket[syntax-case] and @racket[syntax].}
+that treat it specially like @racket[->]), where it indicates repetitions
+of a pattern or template. See @racket[syntax-case] and @racket[syntax].}
 
 @defidform[_]{
 

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

@@ -341,6 +341,34 @@
       (eq? f (contract (-> any/c any) f 'pos 'neg)))
    #f)
   
+  (test/spec-passed/result
+   'contract->...1
+   '((contract (-> integer? char? ... boolean? any)
+               (λ args args)
+               'pos 'neg)
+     1 #\a #\b #\c #f)
+   '(1 #\a #\b #\c #f))
+  (test/neg-blame
+   'contract->...2
+   '((contract (-> integer? char? ... boolean? any)
+               (λ args args)
+               'pos 'neg)
+     1 #\a "b" #\c #f))
+  (test/spec-passed/result
+   'contract->...3
+   '((contract (-> integer? ... any)
+               (λ args args)
+               'pos 'neg)
+     1 2 3 4 5 6 7)
+   '(1 2 3 4 5 6 7))
+  (test/neg-blame
+   'contract->...4
+   '((contract (-> integer? ... any)
+               (λ args args)
+               'pos 'neg)
+     1 2 3 4 5 6 7)
+   '(1 2 3 4 5 "6" 7))
+
   
   (test/spec-passed
    'contract-arrow-all-kwds2
@@ -557,4 +585,27 @@
                  'neg))
       (void)))
 
+  (test/spec-passed/result
+   '->-order-of-evaluation1
+   '(let ([l '()])
+      (-> (begin (set! l (cons 1 l)) #f)
+          (begin (set! l (cons 2 l)) #f)
+          (begin (set! l (cons 3 l)) #f)
+          (begin (set! l (cons 4 l)) #f)
+          (begin (set! l (cons 5 l)) #f))
+      (reverse l))
+   '(1 2 3 4 5))
+  (test/spec-passed/result
+   '->-order-of-evaluation2
+   '(let ([l '()])
+      (-> (begin (set! l (cons 1 l)) #f)
+          (begin (set! l (cons 2 l)) #f)
+          (begin (set! l (cons 3 l)) #f)
+          ...
+          (begin (set! l (cons 4 l)) #f)
+          (begin (set! l (cons 5 l)) #f)
+          (begin (set! l (cons 6 l)) #f))
+      (reverse l))
+   '(1 2 3 4 5))
+  
   )

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

@@ -78,8 +78,16 @@
               (valid-app-shapes '(2) '() '()))
 (check-equal? (->-valid-app-shapes #'(-> integer? #:x any/c integer?))
               (valid-app-shapes '(1) '(#:x) '()))
-(check-equal? (->-valid-app-shapes #'(-> integer? #:x any/c #:y any/c integer?))
+(check-equal? (->-valid-app-shapes #'(-> integer? (... ...) any))
-              (valid-app-shapes '(1) '(#:x #:y) '()))
+              (valid-app-shapes 0 '() '()))
+(check-equal? (->-valid-app-shapes #'(-> integer? integer? (... ...) any))
+              (valid-app-shapes 1 '() '()))
+(check-equal? (->-valid-app-shapes #'(-> integer? integer? (... ...) integer? any))
+              (valid-app-shapes 2 '() '()))
+(check-equal? (->-valid-app-shapes #'(-> integer? integer? (... ...) integer? boolean? char? any))
+              (valid-app-shapes 4 '() '()))
+(check-equal? (->-valid-app-shapes #'(-> integer? boolean? char? (... ...) integer? char? any))
+              (valid-app-shapes 4 '() '()))
 
 (check-equal? (->*-valid-app-shapes #'(->* (integer? #:x any/c #:y any/c) integer?))
               (valid-app-shapes '(1) '(#:x #:y) '()))
@@ -97,7 +105,6 @@
 (check-equal? (->*-valid-app-shapes #'(->i ([m any/c]) ([o any/c]) #:rest [r any/c] [r any/c]))
               (valid-app-shapes '(1 2 . 3) '() '()))
 
-              
 (check-true  (valid-argument-list? #'(f x) (valid-app-shapes '(1 2 . 3) '() '())))
 (check-true  (valid-argument-list? #'(f x y) (valid-app-shapes '(1 2 . 3) '() '())))
 (check-true  (valid-argument-list? #'(f x y a b c d) (valid-app-shapes '(1 2 . 3) '() '())))

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

@@ -65,6 +65,8 @@
   (test-name '(-> any/c boolean?) (-> any/c boolean?))
   (test-name 'predicate/c predicate/c)
 
+  (test-name '(-> integer? any/c ... boolean? any) (-> integer? any/c ... boolean? any))
+  
   (test-name '(->* (integer?) (string?) #:rest any/c (values char? any/c))
               (->* (integer?) (string?) #:rest any/c (values char? any/c)))
   (test-name '(->* (integer? char?) (boolean?) any) (->* (integer? char?) (boolean?) any))

racket/collects/racket/contract/private/arrow-higher-order.rkt

@@ -8,6 +8,7 @@
          "misc.rkt"
          "prop.rkt"
          "guts.rkt"
+         "list.rkt"
          (prefix-in arrow: "arrow.rkt")
          (only-in racket/unsafe/ops
                   unsafe-chaperone-procedure
@@ -461,10 +462,14 @@
          (blame-add-context orig-blame 
                             (format "the ~a argument of" (n->th n))
                             #:swap? #t))))
+    (define rest-blame
+      (if (ellipsis-rest-arg-ctc? rest)
+          (blame-swap orig-blame)
+          (blame-add-context orig-blame "the rest argument of"
+                             #:swap? #t)))
     (define partial-rest (and rest
                               ((get/build-late-neg-projection rest)
-                               (blame-add-context orig-blame "the rest argument of"
+                               rest-blame)))
-                                                  #:swap? #t))))
     (define partial-ranges
       (if rngs
           (for/list ([rng (in-list rngs)])

racket/collects/racket/contract/private/arrow-val-first.rkt

@@ -9,6 +9,7 @@
          "guts.rkt"
          "generate.rkt"
          "arrow-higher-order.rkt"
+         "list.rkt"
          racket/stxparam
          (prefix-in arrow: "arrow.rkt"))
 
@@ -551,7 +552,8 @@
              [regular-args '()]
              [kwds '()]
              [kwd-args '()]
-             [let-bindings '()])
+             [let-bindings '()]
+             [ellipsis #f])
     (cond
       [(null? args) 
        (define sorted
@@ -561,18 +563,52 @@
        (values (reverse regular-args)
                (map car sorted)
                (map cdr sorted)
-               let-bindings)]
+               (reverse let-bindings)
+               #f)]
       [else
-       (with-syntax ([(arg-x) (generate-temporaries (list (car args)))])
+       (cond
-         (syntax-case (car args) ()
+         [(and (identifier? (car args)) (free-identifier=? (car args) #'(... ...)))
-           [kwd
+          (when ellipsis
-            (keyword? (syntax-e #'kwd))
+            (raise-syntax-error '-> "expected at most one ellipsis"
-            (begin
+                                stx (car args) ellipsis))
+          (when (null? regular-args)
+            (raise-syntax-error '->
+                                "expected the ellipsis to follow a contract"
+                                stx
+                                (car args)))
+          (for ([arg (in-list (cdr args))])
+            (when (keyword? (syntax-e arg))
+              (raise-syntax-error '->
+                                  "keywords are not allowed after the ellipsis"
+                                  stx arg)))
+          (define sorted
+            (sort (map cons kwds kwd-args)
+                  keyword<?
+                  #:key (compose syntax-e car)))
+          (define arg-xes (generate-temporaries (cdr args)))
+          (values (reverse (cdr regular-args))
+                  (map car sorted)
+                  (map cdr sorted)
+                  (append (reverse let-bindings)
+                          (for/list ([arg-exp (cdr args)]
+                                     [arg-x (in-list arg-xes)])
+                            #`[#,arg-x #,(syntax-property arg-exp 
+                                                          'racket/contract:negative-position 
+                                                          this->)]))
+                  (cons (car regular-args) arg-xes))]
+         [(keyword? (syntax-e (car args)))
           (when (null? (cdr args))
             (raise-syntax-error '-> 
                                 "expected a contract to follow the keyword (plus the range)"
                                 stx
                                 (car args)))
+          (when (and (identifier? (cadr args))
+                     (free-identifier=? (cadr args) #'(... ...)))
+            (raise-syntax-error '->
+                                "expected a contract to follow a keyword, not an ellipsis"
+                                stx
+                                (car args)))
+          (with-syntax ([(arg-x) (generate-temporaries (list (car args)))])
             (loop (cddr args)
                   regular-args
                   (cons (car args) kwds)
@@ -580,8 +616,10 @@
                   (cons #`[arg-x #,(syntax-property (cadr args) 
                                                     'racket/contract:negative-position 
                                                     this->)]
-                          let-bindings)))]
+                        let-bindings)
+                  ellipsis))]
          [else
+          (with-syntax ([(arg-x) (generate-temporaries (list (car args)))])
             (loop (cdr args)
                   (cons #'arg-x regular-args)
                   kwds
@@ -589,16 +627,20 @@
                   (cons #`[arg-x #,(syntax-property (car args) 
                                                     'racket/contract:negative-position 
                                                     this->)]
-                        let-bindings))]))])))
+                        let-bindings)
+                  ellipsis))])])))
 
 (define-for-syntax (->-valid-app-shapes stx)
   (syntax-case stx ()
     [(_ args ...)
      (let ()
        (define this-> (gensym 'this->))
-       (define-values (regular-args kwds kwd-args let-bindings)
+       (define-values (regular-args kwds kwd-args let-bindings ellipsis-info)
          (parse-arrow-args stx (syntax->list #'(args ...)) this->))
-       (valid-app-shapes (list (- (length regular-args) 1))
+       (define arg-count (- (length regular-args) 1))
+       (valid-app-shapes (if ellipsis-info
+                             (+ arg-count (- (length ellipsis-info) 1))
+                             (list arg-count))
                          (map syntax->datum kwds)
                          '()))]))
 
@@ -610,7 +652,7 @@
     [(_ args ... rng)
      (let ()
        (define this-> (gensym 'this->))
-       (define-values (regular-args kwds kwd-args let-bindings)
+       (define-values (regular-args kwds kwd-args let-bindings ellipsis-info)
          (parse-arrow-args stx (syntax->list #'(args ...)) this->))
        (define (add-pos-obligations stxes)
          (for/list ([stx (in-list stxes)])
@@ -622,7 +664,7 @@
            [rng (add-pos-obligations (list #'rng))]))
        (define-values (plus-one-arity-function chaperone-constructor)
          (build-plus-one-arity-function+chaperone-constructor 
-          regular-args '() kwds '() #f #f #f rngs #f #f))
+          regular-args '() kwds '() #f #f (and ellipsis-info #t) rngs #f #f))
        (syntax-property
         #`(let #,let-bindings
             #,(quasisyntax/loc stx
@@ -634,7 +676,10 @@
                        #`(list #,@rngs)
                        #'#f)
                  #,plus-one-arity-function
-                 #,chaperone-constructor)))
+                 #,chaperone-constructor
+                 #,(if ellipsis-info
+                       #`(ellipsis-rest-arg #,(length regular-args) #,@ellipsis-info)
+                       #'#f))))
         'racket/contract:contract
         (vector this->
                 ;; the -> in the original input to this guy
@@ -805,12 +850,13 @@
                          mandatory-kwds mandatory-raw-kwd-doms
                          raw-rngs
                          plus-one-arity-function
-                         chaperone-constructor)
+                         chaperone-constructor
+                         raw-rest-ctc)
   (build--> '->
             raw-regular-doms '() 
             mandatory-kwds mandatory-raw-kwd-doms
             '() '()
-            #f
+            raw-rest-ctc
             #f raw-rngs #f
             plus-one-arity-function
             chaperone-constructor))
@@ -1168,16 +1214,29 @@
        [(and (andmap kwd-info-mandatory? (base->-kwd-infos ctc))
              (= (base->-min-arity ctc)
                 (length (base->-doms ctc)))
-             (not (base->-rest ctc))
+             (or (not (base->-rest ctc))
+                 (ellipsis-rest-arg-ctc? (base->-rest ctc)))
              (not (base->-pre? ctc))
              (not (base->-post? ctc)))
-        `(-> ,@(map contract-name (base->-doms ctc))
+        (define kwd-args
-             ,@(apply
+          (apply
            append
-                (for/list ([kwd-info (base->-kwd-infos ctc)])
+           (for/list ([kwd-info (in-list (base->-kwd-infos ctc))])
              (list (kwd-info-kwd kwd-info)
-                        (contract-name (kwd-info-ctc kwd-info)))))
+                   (contract-name (kwd-info-ctc kwd-info))))))
+        (cond
+          [(ellipsis-rest-arg-ctc? (base->-rest ctc))
+           `(-> ,@(map contract-name (base->-doms ctc))
+                ,@kwd-args
+                ,(contract-name (*list-ctc-prefix (base->-rest ctc)))
+                ...
+                ,@(for/list ([ctc (in-list (*list-ctc-suffix (base->-rest ctc)))])
+                    (contract-name ctc))
                 ,rng-sexp)]
+          [else
+           `(-> ,@(map contract-name (base->-doms ctc))
+                ,@kwd-args
+                ,rng-sexp)])]
        [else
         (define (take l n) (reverse (list-tail (reverse l) (- (length l) n))))
         (define mandatory-args

racket/collects/racket/contract/private/arrow.rkt

@@ -4,6 +4,7 @@
          "blame.rkt"
          "prop.rkt"
          "misc.rkt"
+         "list.rkt"
          racket/stxparam
          racket/private/performance-hint)
 (require (for-syntax racket/base)
@@ -619,7 +620,8 @@
          [func (base->-func ctc)]
          [dom-length (length (base->-doms/c ctc))]
          [optionals-length (length (base->-optional-doms/c ctc))]
-         [has-rest? (and (base->-dom-rest/c ctc) #t)]
+         [rest-ctc (base->-dom-rest/c ctc)]
+         [has-rest? (and rest-ctc #t)]
          [pre (base->-pre ctc)]
          [post (base->-post ctc)]
          [mtd? (base->-mtd? ctc)])
@@ -628,13 +630,21 @@
       (define partial-doms 
         (for/list ([dom (in-list doms-proj)]
                    [n (in-naturals 1)])
-          (dom (blame-add-context orig-blame
+          (define dom-blame
+            (cond
+              [(and has-rest?
+                    (n . > . dom-length)
+                    (ellipsis-rest-arg-ctc? rest-ctc))
+               (blame-swap orig-blame)]
+              [else
+               (blame-add-context orig-blame
                                   (if (and has-rest?
                                            (n . > . dom-length))
                                       "the rest argument of"
                                       (format "the ~a argument of"
                                               (n->th n)))
-                                  #:swap? #t))))
+                                  #:swap? #t)]))
+          (dom dom-blame)))
       (define partial-optional-doms 
         (for/list ([dom (in-list doms-optional-proj)]
                    [n (in-naturals (+ 1 (length doms-proj)))])

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

@@ -15,7 +15,9 @@
          blame-add-car-context
          blame-add-cdr-context
          raise-not-cons-blame-error
-         *list/c)
+         *list/c ellipsis-rest-arg
+         (struct-out ellipsis-rest-arg-ctc)
+         (struct-out *list-ctc))
 
 (define (listof-generate ctc)
   (cond
@@ -873,20 +875,26 @@
             (contract-struct-stronger? suf that-elem)))]
     [else #f]))
 
-(define (*list/c-late-neg-projection ctc flat?)
+(define (*list/c-late-neg-projection ctc start-index 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 prefix-val-acceptor
+      (prefix-lnp (if start-index
+                      (blame-add-context blame "the repeated argument of")
+                      (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"
+              (if start-index "the last argument of" "the last element of")
-              (format "the ~a to the last element of" (n->th which))))
+              (format (if start-index
+                          "the ~a to the last argument of"
+                          "the ~a to the last element of")
+                      (n->th which))))
         (suffix-lnp (blame-add-context blame msg))))
     (λ (val neg-party)
       (cond
@@ -914,12 +922,18 @@
                      (loop (cdr remainder-to-process) (cdr end))
                      (cons fst (loop (cdr remainder-to-process) (cdr end))))]))]
            [else
+            (if start-index
+                (raise-blame-error
+                 blame
+                 val
+                 '(expected: "at least ~a arguments"
+                             (+ start-index suffix?s-len)))
                 (raise-blame-error
                  blame
                  val
                  '(expected: "list? with at least ~a elements" given: "~e")
                  suffix?s-len
-             val)])]
+                 val))])]
         [else (raise-blame-error
                blame
                val
@@ -938,7 +952,7 @@
    #:generate *list/c-generate
    #:exercise *list/c-exercise
    #:stronger *list/c-stronger
-   #:late-neg-projection (λ (ctc) (*list/c-late-neg-projection ctc #t))
+   #:late-neg-projection (λ (ctc) (*list/c-late-neg-projection ctc #f #t))
    #:list-contract? (λ (c) #t)))
 (struct chaperone-*list/c *list-ctc ()
   #:property prop:contract
@@ -948,7 +962,7 @@
    #:generate *list/c-generate
    #:exercise *list/c-exercise
    #:stronger *list/c-stronger
-   #:late-neg-projection (λ (ctc) (*list/c-late-neg-projection ctc #f))
+   #:late-neg-projection (λ (ctc) (*list/c-late-neg-projection ctc #f #f))
    #:list-contract? (λ (c) #t)))
 (struct impersonator-*list/c *list-ctc ()
   #:property prop:contract
@@ -958,7 +972,7 @@
    #:generate *list/c-generate
    #:exercise *list/c-exercise
    #:stronger *list/c-stronger
-   #:late-neg-projection (λ (ctc) (*list/c-late-neg-projection ctc #f))
+   #:late-neg-projection (λ (ctc) (*list/c-late-neg-projection ctc #f #f))
    #:list-contract? (λ (c) #t)))
 
 (define (*list/c ele . rest)
@@ -978,3 +992,51 @@
  (listof any/c)
  (cons/c any/c any/c)
  (list/c))
+
+;; used by -> when it gets an ellipsis. This
+;; contract turns into the equivalent of the #:rest
+;; argument (if the same contract had been an ->*)
+(define (ellipsis-rest-arg start-index . eles)
+  (define ctcs (coerce-contracts '-> eles))
+  (cond
+    [(andmap flat-contract? ctcs)
+     (flat-ellipsis-rest-arg (car ctcs) (cdr ctcs) start-index)]
+    [(andmap chaperone-contract? ctcs)
+     (chaperone-ellipsis-rest-arg (car ctcs) (cdr ctcs) start-index)]
+    [else
+     (impersonator-ellipsis-rest-arg (car ctcs) (cdr ctcs) start-index)]))
+
+(struct ellipsis-rest-arg-ctc *list-ctc (start-index))
+(struct flat-ellipsis-rest-arg ellipsis-rest-arg-ctc ()
+  #:property prop:contract
+  (build-contract-property
+   #:name (λ (ctc) (error 'flat-ellipsis-rest-arg "the name property shouldn't be called!"))
+   #: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 (ellipsis-rest-arg-ctc-start-index ctc) #t))
+   #:list-contract? (λ (c) #t)))
+(struct chaperone-ellipsis-rest-arg ellipsis-rest-arg-ctc ()
+  #:property prop:contract
+  (build-contract-property
+   #:name (λ (ctc) (error 'flat-ellipsis-rest-arg "the name property shouldn't be called!"))
+   #: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 (ellipsis-rest-arg-ctc-start-index ctc) #f))
+   #:list-contract? (λ (c) #t)))
+(struct impersonator-ellipsis-rest-arg ellipsis-rest-arg-ctc ()
+  #:property prop:contract
+  (build-contract-property
+   #:name (λ (ctc) (error 'flat-ellipsis-rest-arg "the name property shouldn't be called!"))
+   #: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 (ellipsis-rest-arg-ctc-start-index ctc) #f))
+   #:list-contract? (λ (c) #t)))