suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
also fix order of evaluation for ->
This commit is contained in:
Robby Findler 2016-01-28 15:33:37 -06:00
parent 856e60fe51
commit ec4bd288bf
9 changed files with 282 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
pkgs/racket-doc/scribblings/reference/contracts.scrbl
View File

@ -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

5
pkgs/racket-doc/scribblings/reference/stx-patterns.scrbl
View File

@ -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[_]{

51
pkgs/racket-test/tests/racket/contract/arrow.rkt
View File

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

13
pkgs/racket-test/tests/racket/contract/helpers.rkt
View File

@ -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) '() '())))

2
pkgs/racket-test/tests/racket/contract/name.rkt
View File

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

9
racket/collects/racket/contract/private/arrow-higher-order.rkt
View File

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

101
racket/collects/racket/contract/private/arrow-val-first.rkt
View File

@ -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)))])
(syntax-case (car args) ()
[kwd
(keyword? (syntax-e #'kwd))
(begin
(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<?
#: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))
,@(apply
(define kwd-args
(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

16
racket/collects/racket/contract/private/arrow.rkt
View File

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

80
racket/collects/racket/contract/private/list.rkt
View File

@ -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
(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)))