add #:pre/desc to ->*
This commit is contained in:
Robby Findler
parent
3d48ef78f6
commit
9d58a067e3
|
|
@ -976,9 +976,13 @@ each value must match its respective contract.}
|
|||
[optional-doms (code:line) (optional-dom ...)]
|
||||
[optional-dom dom-expr (code:line keyword dom-expr)]
|
||||
[rest (code:line) (code:line #:rest rest-expr)]
|
||||
[pre (code:line) (code:line #:pre pre-cond-expr)]
|
||||
[pre (code:line)
|
||||
(code:line #:pre pre-cond-expr)
|
||||
(code:line #:pre/desc pre-cond-expr)]
|
||||
[range range-expr (values range-expr ...) any]
|
||||
[post (code:line) (code:line #:post post-cond-expr)])]{
|
||||
[post (code:line)
|
||||
(code:line #:post post-cond-expr)
|
||||
(code:line #:post/desc post-cond-expr)])]{
|
||||
|
||||
The @racket[->*] contract combinator produces contracts for functions
|
||||
that accept optional arguments (either keyword or positional) and/or
|
||||
|
|
@ -1005,14 +1009,24 @@ going to end up disallowing empty argument lists.
|
|||
The @racket[pre-cond-expr] and @racket[post-cond-expr]
|
||||
expressions are checked as the function is called and returns,
|
||||
respectively, and allow checking of the environment without an
|
||||
explicit connection to an argument (or a result).
|
||||
explicit connection to an argument (or a result). If the @racket[#:pre]
|
||||
or @racket[#:post] keywords are used, then a @racket[#f] result is
|
||||
treated as a failure and any other result is treated as success.
|
||||
If the @racket[#:pre/desc] or @racket[#:post/desc] keyword is used,
|
||||
the result of the expression must be either a boolean, a string, or a
|
||||
list of strings, where @racket[#t] means success and any of the other
|
||||
results mean failure. If the result is a string or a list of strings,
|
||||
the strings are expected to have at exactly one space after each
|
||||
newline and multiple are used as lines in the error message; the contract
|
||||
itself adds single space of indentation to each of the strings in that case.
|
||||
The formatting requirements are not checked but they
|
||||
match the recommendations in @secref["err-msg-conventions"].
|
||||
|
||||
As an example, the contract
|
||||
@racketblock[(->* () (boolean? #:x integer?) #:rest (listof symbol?) symbol?)]
|
||||
matches functions that optionally accept a boolean, an
|
||||
integer keyword argument @racket[#:x] and arbitrarily more
|
||||
symbols, and that return a symbol.
|
||||
|
||||
}
|
||||
|
||||
@defform*/subs[#:literals (any values)
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@
|
|||
(values (flat-contract integer?) (flat-contract boolean?))))
|
||||
(test/no-error '(->* ((flat-contract integer?)) () #:rest (flat-contract integer?) any))
|
||||
(test/no-error '(->* ((flat-contract integer?)) () #:pre #t (flat-contract integer?) #:post #t))
|
||||
(test/no-error '(->* (any/c) () #:pre/desc #t (flat-contract integer?) #:post/desc #t))
|
||||
|
||||
|
||||
|
||||
|
|
@ -602,6 +603,84 @@
|
|||
'pos
|
||||
'neg)))
|
||||
|
||||
(test/neg-blame
|
||||
'->*pre/post-8
|
||||
'((contract (->* () () #:pre/desc #f integer? #:post/desc #f)
|
||||
(λ () 1)
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(test/neg-blame
|
||||
'->*pre/post-9
|
||||
'((contract (->* () () #:pre/desc "" integer? #:post/desc #f)
|
||||
(λ () 1)
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(test/neg-blame
|
||||
'->*pre/post-10
|
||||
'((contract (->* () () #:pre/desc '("qqq") integer? #:post/desc #f)
|
||||
(λ () 1)
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(test/pos-blame
|
||||
'->*pre/post-11
|
||||
'((contract (->* () () #:pre/desc #t integer? #:post/desc #f)
|
||||
(λ () 1)
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(test/pos-blame
|
||||
'->*pre/post-12
|
||||
'((contract (->* () () #:pre/desc #t integer? #:post/desc "")
|
||||
(λ () 1)
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(test/pos-blame
|
||||
'->*pre/post-13
|
||||
'((contract (->* () () #:pre/desc #t integer? #:post/desc '("qqc"))
|
||||
(λ () 1)
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(test/pos-blame
|
||||
'->*pre/post-14
|
||||
'((contract (->* () () #:pre/desc #t integer? #:post/desc '("qqc"))
|
||||
(λ () 1)
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(test/neg-blame
|
||||
'->*pre/post-15
|
||||
'((contract (->* (integer?) #:pre/desc '("something" "not so great" "happened") any)
|
||||
(λ (x) 1)
|
||||
'pos 'neg)
|
||||
1))
|
||||
|
||||
(contract-error-test
|
||||
'->*pre/post-16
|
||||
'((contract (->* () () #:pre/desc '("something wonderful") integer? #:post/desc '("qqc"))
|
||||
(λ () 1)
|
||||
'pos
|
||||
'neg))
|
||||
(λ (x)
|
||||
(and (exn:fail:contract? x)
|
||||
(regexp-match #rx"\n *something wonderful\n"
|
||||
(exn-message x)))))
|
||||
|
||||
(contract-error-test
|
||||
'->*pre/post-17
|
||||
'((contract (->* () () integer? #:post/desc "something horrible")
|
||||
(λ () 1)
|
||||
'pos
|
||||
'neg))
|
||||
(λ (x)
|
||||
(and (exn:fail:contract? x)
|
||||
(regexp-match #rx"\n *something horrible\n"
|
||||
(exn-message x)))))
|
||||
|
||||
(test/spec-passed
|
||||
'->*-opt-optional1
|
||||
'((contract (->* () integer?) (lambda () 1) 'pos 'neg)))
|
||||
|
|
|
|||
|
|
@ -12,17 +12,19 @@
|
|||
(prefix-in arrow: "arrow.rkt"))
|
||||
|
||||
(provide (for-syntax build-chaperone-constructor/real)
|
||||
->-proj)
|
||||
->-proj
|
||||
check-pre-cond
|
||||
check-post-cond)
|
||||
|
||||
(define-for-syntax (build-chaperone-constructor/real this-args
|
||||
mandatory-dom-projs
|
||||
optional-dom-projs
|
||||
mandatory-dom-kwds
|
||||
optional-dom-kwds
|
||||
pre
|
||||
pre pre/desc
|
||||
rest
|
||||
rngs
|
||||
post)
|
||||
post post/desc)
|
||||
(define (nvars n sym) (generate-temporaries (for/list ([i (in-range n)]) sym)))
|
||||
(with-syntax ([(mandatory-dom-proj ...) (generate-temporaries mandatory-dom-projs)]
|
||||
[(optional-dom-proj ...) (generate-temporaries optional-dom-projs)]
|
||||
|
|
@ -48,10 +50,11 @@
|
|||
(map list
|
||||
optional-dom-kwds
|
||||
(syntax->list #'(optional-dom-kwd-proj ...)))
|
||||
pre
|
||||
pre pre/desc
|
||||
(if rest (car (syntax->list #'(rest-proj ...))) #f)
|
||||
(if rngs (syntax->list #'(rng-proj ...)) #f)
|
||||
post))))
|
||||
post post/desc))))
|
||||
|
||||
|
||||
(define (check-pre-cond pre blame neg-party val)
|
||||
(unless (pre)
|
||||
|
|
@ -65,24 +68,68 @@
|
|||
#:missing-party neg-party
|
||||
val "#:post condition")))
|
||||
|
||||
(define (check-pre-cond/desc post blame neg-party val)
|
||||
(handle-pre-post/desc-string #t post blame neg-party val))
|
||||
(define (check-post-cond/desc post blame neg-party val)
|
||||
(handle-pre-post/desc-string #f post blame neg-party val))
|
||||
(define (handle-pre-post/desc-string pre? thunk blame neg-party val)
|
||||
(define condition-result (thunk))
|
||||
(cond
|
||||
[(equal? condition-result #t)
|
||||
(void)]
|
||||
[else
|
||||
(define msg
|
||||
(cond
|
||||
[(equal? condition-result #f)
|
||||
(if pre?
|
||||
"#:pre condition"
|
||||
"#:post condition")]
|
||||
[(string? condition-result) condition-result]
|
||||
[(and (list? condition-result)
|
||||
(andmap string? condition-result))
|
||||
(apply
|
||||
string-append
|
||||
(let loop ([s condition-result])
|
||||
(cond
|
||||
[(null? s) '()]
|
||||
[(null? (cdr s)) s]
|
||||
[else (list* (car s)
|
||||
"\n "
|
||||
(loop (cdr s)))])))]
|
||||
[else
|
||||
(error
|
||||
'->*
|
||||
"expected #:~a/desc to produce (or/c boolean? string? (listof string?)), got ~e"
|
||||
(if pre? "pre" "post")
|
||||
condition-result)]))
|
||||
(raise-blame-error (if pre? (blame-swap blame) blame)
|
||||
#:missing-party neg-party
|
||||
val "~a" msg)]))
|
||||
|
||||
(define-for-syntax (create-chaperone blame val
|
||||
this-args
|
||||
doms opt-doms
|
||||
req-kwds opt-kwds
|
||||
pre
|
||||
pre pre/desc
|
||||
dom-rest
|
||||
rngs
|
||||
post)
|
||||
post post/desc)
|
||||
(with-syntax ([blame blame]
|
||||
[val val])
|
||||
(with-syntax ([(pre ...)
|
||||
(if pre
|
||||
(list #`(check-pre-cond #,pre blame neg-party val))
|
||||
null)]
|
||||
(cond
|
||||
[pre
|
||||
(list #`(check-pre-cond #,pre blame neg-party val))]
|
||||
[pre/desc
|
||||
(list #`(check-pre-cond/desc #,pre/desc blame neg-party val))]
|
||||
[else null])]
|
||||
[(post ...)
|
||||
(if post
|
||||
(list #`(check-post-cond #,post blame neg-party val))
|
||||
null)])
|
||||
(cond
|
||||
[post
|
||||
(list #`(check-post-cond #,post blame neg-party val))]
|
||||
[post/desc
|
||||
(list #`(check-post-cond/desc #,post/desc blame neg-party val))]
|
||||
[else null])])
|
||||
(with-syntax ([(this-param ...) this-args]
|
||||
[(dom-ctc ...) doms]
|
||||
[(dom-x ...) (generate-temporaries doms)]
|
||||
|
|
|
|||
|
|
@ -73,12 +73,12 @@
|
|||
optional-args
|
||||
mandatory-kwds
|
||||
optional-kwds
|
||||
pre
|
||||
pre pre/desc
|
||||
rest
|
||||
rngs
|
||||
post)
|
||||
(define key (and (not pre)
|
||||
(not post)
|
||||
post post/desc)
|
||||
(define key (and (not pre) (not pre/desc)
|
||||
(not post) (not post/desc)
|
||||
(list (length regular-args)
|
||||
(length optional-args)
|
||||
(map syntax-e mandatory-kwds)
|
||||
|
|
@ -100,20 +100,20 @@
|
|||
optional-args
|
||||
mandatory-kwds
|
||||
optional-kwds
|
||||
pre
|
||||
pre pre/desc
|
||||
rest
|
||||
rngs
|
||||
post)
|
||||
post post/desc)
|
||||
(build-chaperone-constructor/real
|
||||
'() ;; this-args
|
||||
regular-args
|
||||
optional-args
|
||||
mandatory-kwds
|
||||
optional-kwds
|
||||
pre
|
||||
pre pre/desc
|
||||
rest
|
||||
rngs
|
||||
post))]))
|
||||
post post/desc))]))
|
||||
|
||||
(define-syntax (build-populars stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -142,20 +142,20 @@
|
|||
mans opts
|
||||
mandatory-kwds
|
||||
optional-kwds
|
||||
#f
|
||||
#f #f
|
||||
rest
|
||||
rng-vars
|
||||
#f))
|
||||
#f #f))
|
||||
(define #,(syntax-local-introduce chaperone-id)
|
||||
#,(build-chaperone-constructor/real
|
||||
'() ;; this arg
|
||||
mans opts
|
||||
mandatory-kwds
|
||||
optional-kwds
|
||||
#f
|
||||
#f #f
|
||||
rest
|
||||
rng-vars
|
||||
#f))))
|
||||
#f #f))))
|
||||
(define popular-chaperone-key-table
|
||||
(make-hash
|
||||
(list #,@(for/list ([id (in-list popular-key-ids)]
|
||||
|
|
@ -167,10 +167,10 @@
|
|||
optional-args
|
||||
mandatory-kwds
|
||||
optional-kwds
|
||||
pre
|
||||
pre pre/desc
|
||||
rest
|
||||
rngs
|
||||
post)
|
||||
post post/desc)
|
||||
(with-syntax ([(regb ...) (generate-temporaries regular-args)]
|
||||
[(optb ...) (generate-temporaries optional-args)]
|
||||
[(kb ...) (generate-temporaries mandatory-kwds)]
|
||||
|
|
@ -194,11 +194,11 @@
|
|||
[(the-call ...) #'(f ((regb arg-x) neg-party) ... kwd-arg-exps ...)]
|
||||
[(pre-check ...)
|
||||
(if pre
|
||||
(list #`(check-pre-condition blame neg-party f #,pre))
|
||||
(list #`(check-pre-cond #,pre blame neg-party f))
|
||||
(list))]
|
||||
[(post-check ...)
|
||||
(if post
|
||||
(list #`(check-post-condition blame neg-party f #,post))
|
||||
(list #`(check-post-cond #,post blame neg-party f))
|
||||
(list))]
|
||||
[(restb) (generate-temporaries '(rest-args))])
|
||||
(define body-proc
|
||||
|
|
@ -412,19 +412,6 @@
|
|||
[(keyword<? opt-kwd kwd)
|
||||
(loop mandatory-kwds (cdr optional-kwds) kwds)])])])))
|
||||
|
||||
|
||||
(define (check-pre-condition blame neg-party val thunk)
|
||||
(unless (thunk)
|
||||
(raise-blame-error
|
||||
(blame-swap blame) #:missing-party neg-party val
|
||||
"#:pre condition failure")))
|
||||
|
||||
(define (check-post-condition blame neg-party val thunk)
|
||||
(unless (thunk)
|
||||
(raise-blame-error
|
||||
blame #:missing-party neg-party val
|
||||
"#:post condition failure")))
|
||||
|
||||
(define-for-syntax (parse-arrow-args stx args this->)
|
||||
(let loop ([args args]
|
||||
[regular-args '()]
|
||||
|
|
@ -501,7 +488,7 @@
|
|||
[rng (add-pos-obligations (list #'rng))]))
|
||||
(define-values (plus-one-arity-function chaperone-constructor)
|
||||
(build-plus-one-arity-function+chaperone-constructor
|
||||
stx regular-args '() kwds '() #f #f rngs #f))
|
||||
stx regular-args '() kwds '() #f #f #f rngs #f #f))
|
||||
(syntax-property
|
||||
#`(let #,let-bindings
|
||||
#,(quasisyntax/loc stx
|
||||
|
|
@ -568,7 +555,7 @@
|
|||
(syntax-case stx ()
|
||||
[(_ (raw-mandatory-dom ...) . other)
|
||||
(let ()
|
||||
(define-values (raw-optional-doms rest-ctc pre rng-ctcs post)
|
||||
(define-values (raw-optional-doms rest-ctc pre pre/desc rng-ctcs post post/desc)
|
||||
(arrow:parse-leftover->* stx #'other))
|
||||
(with-syntax ([(man-dom
|
||||
man-dom-kwds
|
||||
|
|
@ -585,13 +572,13 @@
|
|||
#'opt-dom
|
||||
#'opt-dom-kwds
|
||||
#'opt-lets
|
||||
rest-ctc pre rng-ctcs post)))]))
|
||||
rest-ctc pre pre/desc rng-ctcs post post/desc)))]))
|
||||
|
||||
(define-for-syntax (->*-valid-app-shapes stx)
|
||||
(define this->* (gensym 'this->*))
|
||||
(define-values (man-dom man-dom-kwds man-lets
|
||||
opt-dom opt-dom-kwds opt-lets
|
||||
rest-ctc pre rng-ctcs post)
|
||||
rest-ctc pre pre/desc rng-ctcs post post/desc)
|
||||
(parse->*2 stx this->*))
|
||||
(with-syntax ([((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...) man-dom-kwds]
|
||||
[((optional-dom-kwd optional-dom-kwd-ctc) ...) opt-dom-kwds])
|
||||
|
|
@ -607,7 +594,7 @@
|
|||
(define this->* (gensym 'this->*))
|
||||
(define-values (man-dom man-dom-kwds man-lets
|
||||
opt-dom opt-dom-kwds opt-lets
|
||||
rest-ctc pre rng-ctcs post)
|
||||
rest-ctc pre pre/desc rng-ctcs post post/desc)
|
||||
(parse->*2 stx this->*))
|
||||
(with-syntax ([(mandatory-dom ...) man-dom]
|
||||
[((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...) man-dom-kwds]
|
||||
|
|
@ -618,11 +605,11 @@
|
|||
[(pre-x post-x) (generate-temporaries '(pre-cond post-cond))])
|
||||
(with-syntax ([((kwd dom opt?) ...) #'((mandatory-dom-kwd mandatory-dom-kwd-ctc #f) ...
|
||||
(optional-dom-kwd optional-dom-kwd-ctc #t) ...)]
|
||||
[(pre-let-binding ...) (if pre
|
||||
(list #`[pre-x (λ () #,pre)])
|
||||
(list))]
|
||||
[(post-let-binding ...) (if post
|
||||
(list #`[post-x (λ () #,post)])
|
||||
[(pre-let-binding ...) (if (or pre pre/desc)
|
||||
(list #`[pre-x (λ () #,(or pre pre/desc))])
|
||||
(list))]
|
||||
[(post-let-binding ...) (if (or post post/desc)
|
||||
(list #`[post-x (λ () #,(or post post/desc))])
|
||||
(list))])
|
||||
(define-values (plus-one-arity-function chaperone-constructor)
|
||||
(build-plus-one-arity-function+chaperone-constructor
|
||||
|
|
@ -632,9 +619,11 @@
|
|||
(syntax->list #'(mandatory-dom-kwd ...))
|
||||
(syntax->list #'(optional-dom-kwd ...))
|
||||
(and pre #'pre-x)
|
||||
(and pre/desc #'pre-x)
|
||||
rest-ctc
|
||||
rng-ctcs
|
||||
(and post #'post-x)))
|
||||
(and post #'post-x)
|
||||
(and post/desc #'post-x)))
|
||||
(syntax-property
|
||||
#`(let (mandatory-let-bindings ...
|
||||
optional-let-bindings ...
|
||||
|
|
|
|||
|
|
@ -836,6 +836,8 @@
|
|||
(values #'() leftover)]
|
||||
[(rng #:post . rst)
|
||||
(values #'() leftover)]
|
||||
[(rng #:post/desc . rst)
|
||||
(values #'() leftover)]
|
||||
[(rng)
|
||||
(values #'() leftover)]
|
||||
[((raw-optional-dom ...) . leftover)
|
||||
|
|
@ -847,11 +849,13 @@
|
|||
[(#:rest rest-expr . leftover)
|
||||
(values #'rest-expr #'leftover)]
|
||||
[_ (values #f leftover)])]
|
||||
[(pre leftover)
|
||||
[(pre pre/desc leftover)
|
||||
(syntax-case leftover ()
|
||||
[(#:pre pre-expr . leftover)
|
||||
(values #'pre-expr #'leftover)]
|
||||
[_ (values #f leftover)])]
|
||||
(values #'pre-expr #f #'leftover)]
|
||||
[(#:pre/desc pre-expr . leftover)
|
||||
(values #f #'pre-expr #'leftover)]
|
||||
[_ (values #f #f leftover)])]
|
||||
[(rng leftover)
|
||||
(syntax-case leftover (any values)
|
||||
[(any) (values #f #'())]
|
||||
|
|
@ -865,22 +869,33 @@
|
|||
(values #'(rng) #'leftover))]
|
||||
[_
|
||||
(raise-syntax-error #f "expected a range contract" stx leftover)])]
|
||||
[(post leftover)
|
||||
[(post post/desc leftover)
|
||||
(syntax-case leftover ()
|
||||
[(#:post post-expr . leftover)
|
||||
(values #'post-expr #'leftover)]
|
||||
(values #'post-expr #f #'leftover)]
|
||||
[(#:post/desc post-expr . leftover)
|
||||
(values #f #'post-expr #'leftover)]
|
||||
[else
|
||||
(values #f leftover)])])
|
||||
(values #f #f leftover)])])
|
||||
(syntax-case leftover ()
|
||||
[() (values raw-optional-doms rst pre rng post)]
|
||||
[() (values raw-optional-doms rst pre pre/desc rng post post/desc)]
|
||||
[x (raise-syntax-error #f "expected the end of the contract" stx #'x)])))
|
||||
|
||||
;; ->*/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
|
||||
(define-for-syntax (->*/proc/main stx)
|
||||
(syntax-case* stx (->* any) module-or-top-identifier=?
|
||||
[(->* (raw-mandatory-dom ...) . rst)
|
||||
(let-values ([(raw-optional-doms rest-ctc pre rng-ctc post)
|
||||
(let-values ([(raw-optional-doms rest-ctc raw-pre pre/desc rng-ctc raw-post post/desc)
|
||||
(parse-leftover->* stx #'rst)])
|
||||
(define pre (cond
|
||||
[raw-pre raw-pre]
|
||||
[pre/desc
|
||||
#`(convert-pre-post/desc-to-boolean #t #,pre/desc)]
|
||||
[else #f]))
|
||||
(define post (cond
|
||||
[raw-post raw-post]
|
||||
[post/desc #`(convert-pre-post/desc-to-boolean #f #,post/desc)]
|
||||
[else #f]))
|
||||
(with-syntax ([((mandatory-dom ...) ((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...))
|
||||
(split-doms stx '->* #'(raw-mandatory-dom ...))]
|
||||
[((optional-dom ...) ((optional-dom-kwd optional-dom-kwd-ctc) ...))
|
||||
|
|
@ -962,6 +977,21 @@
|
|||
(syntax->list #'(optional-dom-kwd-proj ...)))
|
||||
(if rng-ctc (syntax->list #'(rng-proj ...)) #f)))))))))))]))
|
||||
|
||||
(define (convert-pre-post/desc-to-boolean pre? b)
|
||||
(cond
|
||||
[(not b) #f]
|
||||
[(or (not b)
|
||||
(string? b)
|
||||
(and (list? b)
|
||||
(andmap string? b)))
|
||||
#f]
|
||||
[(equal? b #t) #t]
|
||||
[else
|
||||
(error '->* "expected #:~a to return (or/c boolean? string? (listof string?)), got ~e"
|
||||
(if pre? "pre" "post")
|
||||
b)]))
|
||||
|
||||
|
||||
(define-syntax (->* stx) #`(syntax-parameterize ((making-a-method #f)) #,(->*/proc/main stx)))
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user