add #:name-for-blame to define-module-boundary-contract
This commit is contained in:
parent
ada002616e
commit
efb96c97b5
|
@ -1963,11 +1963,14 @@ The @racket[define-struct/contract] form only allows a subset of the
|
|||
orig-id
|
||||
contract-expr
|
||||
pos-blame-party
|
||||
source-loc)
|
||||
source-loc
|
||||
name-for-blame)
|
||||
#:grammar ([pos-blame-party (code:line)
|
||||
(code:line #:pos-source pos-source-expr)]
|
||||
[source-loc (code:line)
|
||||
(code:line #:srcloc srcloc-expr)])]{
|
||||
(code:line #:srcloc srcloc-expr)]
|
||||
[name-for-blame (code:line)
|
||||
(code:line #:name-for-blame blame-id)])]{
|
||||
Defines @racket[id] to be @racket[orig-id], but with the contract
|
||||
@racket[contract-expr].
|
||||
|
||||
|
@ -1986,6 +1989,10 @@ The @racket[define-struct/contract] form only allows a subset of the
|
|||
but can be specified via the @racket[#:srcloc] argument, in which case
|
||||
it can be any of the things that the third argument to @racket[datum->syntax]
|
||||
can be.
|
||||
|
||||
The name used in the error messages will be @racket[orig-id], unless
|
||||
@racket[#:name-for-blame] is supplied, in which case the identifier
|
||||
following it is used as the name in the error messages.
|
||||
|
||||
@examples[#:eval (contract-eval) #:once
|
||||
(module server racket/base
|
||||
|
@ -2002,6 +2009,8 @@ The @racket[define-struct/contract] form only allows a subset of the
|
|||
(eval:error (clients-fault))
|
||||
(eval:error (servers-fault))]
|
||||
|
||||
@history[#:changed "6.7.0.4" @elem{Added the @racket[#:name-for-blame] argument.}]
|
||||
|
||||
}
|
||||
|
||||
@defform*[[(contract contract-expr to-protect-expr
|
||||
|
|
|
@ -1555,6 +1555,25 @@
|
|||
(λ (x)
|
||||
(and (exn:fail:contract:blame? x)
|
||||
(regexp-match? #rx"^external-name: " (exn-message x)))))
|
||||
|
||||
(contract-error-test
|
||||
'define-module-boundary-contract5
|
||||
'(begin
|
||||
(eval '(module define-module-boundary-contract5-m racket/base
|
||||
(require racket/contract/base)
|
||||
(define (internal-name x) #f)
|
||||
(define-module-boundary-contract external-name
|
||||
internal-name (-> integer? integer?)
|
||||
#:pos-source 'pos
|
||||
#:name-for-blame my-favorite-name)
|
||||
(provide external-name)))
|
||||
(eval '(module define-module-boundary-contract5-n racket/base
|
||||
(require 'define-module-boundary-contract5-m)
|
||||
(external-name #f)))
|
||||
(eval '(require 'define-module-boundary-contract5-n)))
|
||||
(λ (x)
|
||||
(and (exn:fail:contract:blame? x)
|
||||
(regexp-match? #rx"^my-favorite-name: " (exn-message x)))))
|
||||
|
||||
|
||||
(contract-error-test
|
||||
|
|
|
@ -342,13 +342,15 @@
|
|||
(raise-syntax-error #f "expected an identifier" stx #'new-id))
|
||||
(unless (identifier? #'orig-id)
|
||||
(raise-syntax-error #f "expected an identifier" stx #'orig-id))
|
||||
(define-values (pos-blame-party-expr srcloc-expr)
|
||||
(define-values (pos-blame-party-expr srcloc-expr name-for-blame)
|
||||
(let loop ([kwd-args (syntax->list #'(kwd-args ...))]
|
||||
[pos-blame-party-expr #'(quote-module-path)]
|
||||
[srcloc-expr #f])
|
||||
[srcloc-expr #f]
|
||||
[name-for-blame #f])
|
||||
(cond
|
||||
[(null? kwd-args) (values pos-blame-party-expr
|
||||
(or srcloc-expr (stx->srcloc-expr stx)))]
|
||||
(or srcloc-expr (stx->srcloc-expr stx))
|
||||
(or name-for-blame #'new-id))]
|
||||
[else
|
||||
(define kwd (car kwd-args))
|
||||
(cond
|
||||
|
@ -358,22 +360,39 @@
|
|||
stx))
|
||||
(loop (cddr kwd-args)
|
||||
(cadr kwd-args)
|
||||
srcloc-expr)]
|
||||
srcloc-expr
|
||||
name-for-blame)]
|
||||
[(equal? (syntax-e kwd) '#:srcloc)
|
||||
(when (null? (cdr kwd-args))
|
||||
(raise-syntax-error #f "expected a keyword argument to follow #:srcloc"
|
||||
stx))
|
||||
(loop (cddr kwd-args)
|
||||
pos-blame-party-expr
|
||||
(cadr kwd-args))]
|
||||
(cadr kwd-args)
|
||||
name-for-blame)]
|
||||
[(equal? (syntax-e kwd) '#:name-for-blame)
|
||||
(when (null? (cdr kwd-args))
|
||||
(raise-syntax-error #f "expected a keyword argument to follow #:name-for-blame"
|
||||
stx))
|
||||
(define name-for-blame (cadr kwd-args))
|
||||
(unless (identifier? name-for-blame)
|
||||
(raise-syntax-error #f "expected an identifier to follow #:name-for-blame"
|
||||
stx
|
||||
name-for-blame))
|
||||
(loop (cddr kwd-args)
|
||||
pos-blame-party-expr
|
||||
srcloc-expr
|
||||
name-for-blame)]
|
||||
[else
|
||||
(raise-syntax-error #f "expected either the keyword #:pos-source of #:srcloc"
|
||||
stx
|
||||
(car kwd-args))])])))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected one of the keywords #:pos-source, #:srcloc, or #:name-for-blame"
|
||||
stx
|
||||
(car kwd-args))])])))
|
||||
(internal-function-to-be-figured-out #'ctrct
|
||||
#'orig-id
|
||||
#'orig-id
|
||||
#'new-id
|
||||
name-for-blame
|
||||
#'new-id
|
||||
srcloc-expr
|
||||
'define-module-boundary-contract
|
||||
|
|
Loading…
Reference in New Issue
Block a user