diff --git a/pkgs/racket-doc/scribblings/reference/contracts.scrbl b/pkgs/racket-doc/scribblings/reference/contracts.scrbl index 8fc9722002..efaa63ca08 100644 --- a/pkgs/racket-doc/scribblings/reference/contracts.scrbl +++ b/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) - [(-> dom ... range)] - ([dom dom-expr (code:line keyword dom-expr)] - [range range-expr (values range-expr ...) any])]{ +@(define lit-ellipsis (racket ...)) -Produces a contract for a function that accepts a fixed -number of arguments and returns either a fixed number of +@defform*/subs[#:literals (any values) + [(-> 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 diff --git a/pkgs/racket-doc/scribblings/reference/stx-patterns.scrbl b/pkgs/racket-doc/scribblings/reference/stx-patterns.scrbl index 0e2ff04eac..005939f5f7 100644 --- a/pkgs/racket-doc/scribblings/reference/stx-patterns.scrbl +++ b/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 -template. See @racket[syntax-case] and @racket[syntax].} +patterns and templates (or other unrelated expression forms +that treat it specially like @racket[->]), where it indicates repetitions +of a pattern or template. See @racket[syntax-case] and @racket[syntax].} @defidform[_]{ diff --git a/pkgs/racket-test/tests/racket/contract/arrow.rkt b/pkgs/racket-test/tests/racket/contract/arrow.rkt index dae842be92..b75d064f4a 100644 --- a/pkgs/racket-test/tests/racket/contract/arrow.rkt +++ b/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 @@ -556,5 +584,28 @@ 'pos '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)) ) diff --git a/pkgs/racket-test/tests/racket/contract/helpers.rkt b/pkgs/racket-test/tests/racket/contract/helpers.rkt index abc0d82510..e774ae3ca8 100644 --- a/pkgs/racket-test/tests/racket/contract/helpers.rkt +++ b/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?)) - (valid-app-shapes '(1) '(#:x #:y) '())) +(check-equal? (->-valid-app-shapes #'(-> integer? (... ...) any)) + (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) '() '()))) diff --git a/pkgs/racket-test/tests/racket/contract/name.rkt b/pkgs/racket-test/tests/racket/contract/name.rkt index a9e31c40ce..14f7087109 100644 --- a/pkgs/racket-test/tests/racket/contract/name.rkt +++ b/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)) diff --git a/racket/collects/racket/contract/private/arrow-higher-order.rkt b/racket/collects/racket/contract/private/arrow-higher-order.rkt index 6eaa6481ba..32ff89deda 100644 --- a/racket/collects/racket/contract/private/arrow-higher-order.rkt +++ b/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" - #:swap? #t)))) + rest-blame))) (define partial-ranges (if rngs (for/list ([rng (in-list rngs)]) diff --git a/racket/collects/racket/contract/private/arrow-val-first.rkt b/racket/collects/racket/contract/private/arrow-val-first.rkt index 5935a02985..583ff84663 100644 --- a/racket/collects/racket/contract/private/arrow-val-first.rkt +++ b/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,27 +563,63 @@ (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)))]) - (syntax-case (car args) () - [kwd - (keyword? (syntax-e #'kwd)) - (begin - (when (null? (cdr args)) - (raise-syntax-error '-> - "expected a contract to follow the keyword (plus the range)" - stx - (car args))) - (loop (cddr args) - regular-args - (cons (car args) kwds) - (cons #'arg-x kwd-args) - (cons #`[arg-x #,(syntax-property (cadr args) - 'racket/contract:negative-position - this->)] - let-bindings)))] - [else + (cond + [(and (identifier? (car args)) (free-identifier=? (car args) #'(... ...))) + (when ellipsis + (raise-syntax-error '-> "expected at most one ellipsis" + 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)])) + (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) + (cons #'arg-x kwd-args) + (cons #`[arg-x #,(syntax-property (cadr args) + 'racket/contract:negative-position + this->)] + 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)) - ,@(apply - append - (for/list ([kwd-info (base->-kwd-infos ctc)]) - (list (kwd-info-kwd kwd-info) - (contract-name (kwd-info-ctc kwd-info))))) - ,rng-sexp)] + (define kwd-args + (apply + append + (for/list ([kwd-info (in-list (base->-kwd-infos ctc))]) + (list (kwd-info-kwd 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 diff --git a/racket/collects/racket/contract/private/arrow.rkt b/racket/collects/racket/contract/private/arrow.rkt index 0b5fe8b124..db7a53be29 100644 --- a/racket/collects/racket/contract/private/arrow.rkt +++ b/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)))]) diff --git a/racket/collects/racket/contract/private/list.rkt b/racket/collects/racket/contract/private/list.rkt index 3e6cf61f77..2af97e4dad 100644 --- a/racket/collects/racket/contract/private/list.rkt +++ b/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" - (format "the ~a to the last element of" (n->th which)))) + (if start-index "the last argument of" "the last element of") + (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 - (raise-blame-error - blame - val - '(expected: "list? with at least ~a elements" given: "~e") - suffix?s-len - val)])] + (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))])] [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)))