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

made ->d's optional argument spec itself optional

Browse Source
This commit is contained in:
Robby Findler 2010-07-02 10:06:32 -05:00
parent 389a20795a
commit f83784452e
3 changed files with 133 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -690,7 +690,19 @@ v4 todo:
;; parses everything after the mandatory and optional doms in a ->d contract
(define-for-syntax (parse-leftover stx leftover)
(let*-values ([(id/rest-id leftover)
(let*-values ([(raw-optional-doms leftover)
(syntax-case leftover ()
[(kwd . leftover2)
(keyword? (syntax-e #'kwd))
(values '() leftover)]
[(dep-range)
(values '() leftover)]
[(dep-range #:post-cond expr)
(values '() leftover)]
[((opts ...) . rest)
(values #'(opts ...) #'rest)]
[_ (values '() leftover)])]
[(id/rest-id leftover)
(syntax-case leftover ()
[(#:rest id rest-expr . leftover)
(and (identifier? #'id)
@ -724,7 +736,7 @@ v4 todo:
[_ (values #f leftover)])])
(syntax-case leftover ()
[()
(values id/rest-id pre-cond range post-cond)]
(values raw-optional-doms id/rest-id pre-cond range post-cond)]
[_
(raise-syntax-error #f "bad syntax" stx)])))
@ -771,24 +783,23 @@ v4 todo:
(define-syntax (->d stx)
(syntax-case stx ()
[(_ (raw-mandatory-doms ...)
(raw-optional-doms ...)
.
leftover)
(with-syntax ([(([mandatory-regular-id mandatory-doms] ... ) ([mandatory-kwd (mandatory-kwd-id mandatory-kwd-dom)] ...))
(verify-->d-structure stx (split-doms stx '->d #'(raw-mandatory-doms ...)))]
[(([optional-regular-id optional-doms] ... ) ([optional-kwd (optional-kwd-id optional-kwd-dom)] ...))
(verify-->d-structure stx (split-doms stx '->d #'(raw-optional-doms ...)))])
(with-syntax ([((kwd kwd-id) ...)
(sort-keywords
stx
(syntax->list
#'((optional-kwd optional-kwd-id) ...
(mandatory-kwd mandatory-kwd-id) ...)))]
[(this-parameter ...)
(make-this-parameters (if (syntax? (syntax-parameter-value #'making-a-method))
(car (generate-temporaries '(this)))
(datum->syntax stx 'this #f)))])
(let-values ([(id/rest pre-cond range post-cond) (parse-leftover stx #'leftover)])
(let-values ([(raw-optional-doms id/rest pre-cond range post-cond) (parse-leftover stx #'leftover)])
(with-syntax ([(([mandatory-regular-id mandatory-doms] ... ) ([mandatory-kwd (mandatory-kwd-id mandatory-kwd-dom)] ...))
(verify-->d-structure stx (split-doms stx '->d #'(raw-mandatory-doms ...)))]
[(([optional-regular-id optional-doms] ... ) ([optional-kwd (optional-kwd-id optional-kwd-dom)] ...))
(verify-->d-structure stx (split-doms stx '->d raw-optional-doms))])
(with-syntax ([((kwd kwd-id) ...)
(sort-keywords
stx
(syntax->list
#'((optional-kwd optional-kwd-id) ...
(mandatory-kwd mandatory-kwd-id) ...)))]
[(this-parameter ...)
(make-this-parameters (if (syntax? (syntax-parameter-value #'making-a-method))
(car (generate-temporaries '(this)))
(datum->syntax stx 'this #f)))])
(with-syntax ([(dom-params ...)
#`(this-parameter ...
mandatory-regular-id ...
@ -841,47 +852,47 @@ v4 todo:
(with-syntax ([param old-param])
(syntax/loc stx
(syntax-parameterize
([param (make-this-transformer #'id)])
body)))
([param (make-this-transformer #'id)])
body)))
#'body)])))])
(syntax-parameterize
((making-a-method #f))
(build-->d mtd?
(list (λ (dom-params ...)
(parameterize-this this-parameter ... mandatory-doms)) ...)
(list (λ (dom-params ...)
(parameterize-this this-parameter ... optional-doms)) ...)
(list (λ (dom-params ...)
(parameterize-this this-parameter ... mandatory-kwd-dom)) ...)
(list (λ (dom-params ...)
(parameterize-this this-parameter ... optional-kwd-dom)) ...)
#,(if id/rest
(with-syntax ([(id rst-ctc) id/rest])
#`(λ (dom-params ...)
(parameterize-this this-parameter ... rst-ctc)))
#f)
#,(if pre-cond
#`(λ (dom-params ...)
(parameterize-this this-parameter ... #,pre-cond))
#f)
#,(syntax-case #'rng-ctcs ()
[#f #f]
[(ctc ...)
(if rng-underscores?
#'(box (list (λ (dom-params ...)
(parameterize-this this-parameter ... ctc)) ...))
#'(list (λ (rng-params ... dom-params ...)
(parameterize-this this-parameter ... ctc)) ...))])
#,(if post-cond
#`(λ (rng-params ... dom-params ...)
(parameterize-this this-parameter ... #,post-cond))
#f)
'(mandatory-kwd ...)
'(optional-kwd ...)
(λ (f)
#,(add-name-prop
(syntax-local-infer-name stx)
#`(λ args (apply f args)))))))))))))]))
((making-a-method #f))
(build-->d mtd?
(list (λ (dom-params ...)
(parameterize-this this-parameter ... mandatory-doms)) ...)
(list (λ (dom-params ...)
(parameterize-this this-parameter ... optional-doms)) ...)
(list (λ (dom-params ...)
(parameterize-this this-parameter ... mandatory-kwd-dom)) ...)
(list (λ (dom-params ...)
(parameterize-this this-parameter ... optional-kwd-dom)) ...)
#,(if id/rest
(with-syntax ([(id rst-ctc) id/rest])
#`(λ (dom-params ...)
(parameterize-this this-parameter ... rst-ctc)))
#f)
#,(if pre-cond
#`(λ (dom-params ...)
(parameterize-this this-parameter ... #,pre-cond))
#f)
#,(syntax-case #'rng-ctcs ()
[#f #f]
[(ctc ...)
(if rng-underscores?
#'(box (list (λ (dom-params ...)
(parameterize-this this-parameter ... ctc)) ...))
#'(list (λ (rng-params ... dom-params ...)
(parameterize-this this-parameter ... ctc)) ...))])
#,(if post-cond
#`(λ (rng-params ... dom-params ...)
(parameterize-this this-parameter ... #,post-cond))
#f)
'(mandatory-kwd ...)
'(optional-kwd ...)
(λ (f)
#,(add-name-prop
(syntax-local-infer-name stx)
#`(λ args (apply f args)))))))))))))]))
(define ->d-tail-key (gensym '->d-tail-key))

9
collects/scribblings/reference/contracts.scrbl
View File

@ -501,6 +501,10 @@ symbols, and that return a symbol.
@defform*/subs[#:literals (any values)
[(->d (mandatory-dependent-dom ...)
dependent-rest
pre-cond
dep-range)
(->d (mandatory-dependent-dom ...)
(optional-dependent-dom ...)
dependent-rest
pre-cond
@ -525,8 +529,9 @@ expressions have been added in order to express contracts
that are not naturally tied to a particular argument or
result.
The first two subforms of a @racket[->d] contract cover the
mandatory and optional arguments. Following that is an
The first subforms of a @racket[->d] contract covers the
mandatory and the second (optional) subform covers the optional
arguments. Following that is an
optional rest-args contract, and an optional
pre-condition. The @racket[dep-range] non-terminal covers
the possible post-condition contracts. If it is

58
collects/tests/racket/contract-test.rktl
View File

@ -180,6 +180,7 @@
(test/no-error '(->d ([x integer?]) ([y integer?]) (values [a number?] [b boolean?])))
(test/no-error '(->d ([x integer?] #:z [z integer?]) ([y integer?] #:w [w integer?]) (range boolean?)))
(test/no-error '(->d ([x integer?] #:z [z integer?]) ([y integer?] #:w [w integer?]) #:rest rest any/c (range boolean?)))
(test/no-error '(->d ([x integer?] #:z [z integer?]) #:rest rest any/c (range boolean?)))
(test/no-error '(unconstrained-domain-> number?))
(test/no-error '(unconstrained-domain-> (flat-contract number?)))
@ -1527,6 +1528,63 @@
'neg)
(lambda () (set! x 2)))))
(test/spec-passed
'->d-optopt1
'((contract (->d ([x number?]) any)
(λ (x) x)
'pos 'neg)
1))
(test/spec-passed
'->d-optopt2
'((contract (->d ([x number?]) #:rest rst any/c any)
(λ (x . y) x)
'pos 'neg)
1))
(test/spec-passed
'->d-optopt3
'((contract (->d ([x number?]) #:pre-cond #t any)
(λ (x) x)
'pos 'neg)
1))
(test/spec-passed
'->d-optopt4
'((contract (->d ([x number?]) #:rest rst any/c #:pre-cond #t any)
(λ (x . y) x)
'pos 'neg)
1))
(test/spec-passed
'->d-optopt5
'((contract (->d ([x number?]) #:rest rst any/c #:pre-cond #t [res any/c] #:post-cond #t)
(λ (x . y) x)
'pos 'neg)
1))
(test/spec-passed
'->d-optopt6
'((contract (->d ([x number?]) #:rest rst any/c [res any/c] #:post-cond #t)
(λ (x . y) x)
'pos 'neg)
1))
(test/spec-passed
'->d-optopt7
'((contract (->d ([x number?]) #:pre-cond #t [res any/c] #:post-cond #t)
(λ (x . y) x)
'pos 'neg)
1))
(test/spec-passed
'->d-optopt8
'((contract (->d ([x number?]) [res any/c] #:post-cond #t)
(λ (x . y) x)
'pos 'neg)
1))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;