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

add #:name-for-blame to define-module-boundary-contract

Browse Source
This commit is contained in:
Robby Findler 2017-01-03 07:10:30 -06:00
parent ada002616e
commit efb96c97b5
3 changed files with 58 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1963,11 +1963,14 @@ The @racket[define-struct/contract] form only allows a subset of the
orig-id orig-id
contract-expr contract-expr
pos-blame-party pos-blame-party
source-loc) source-loc
name-for-blame)
#:grammar ([pos-blame-party (code:line) #:grammar ([pos-blame-party (code:line)
(code:line #:pos-source pos-source-expr)] (code:line #:pos-source pos-source-expr)]
[source-loc (code:line) [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 Defines @racket[id] to be @racket[orig-id], but with the contract
@racket[contract-expr]. @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 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] it can be any of the things that the third argument to @racket[datum->syntax]
can be. 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 @examples[#:eval (contract-eval) #:once
(module server racket/base (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 (clients-fault))
(eval:error (servers-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 @defform*[[(contract contract-expr to-protect-expr

19
pkgs/racket-test/tests/racket/contract/contract-out.rkt
View File

@ -1555,6 +1555,25 @@
(λ (x) (λ (x)
(and (exn:fail:contract:blame? x) (and (exn:fail:contract:blame? x)
(regexp-match? #rx"^external-name: " (exn-message 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 (contract-error-test

37
racket/collects/racket/contract/private/provide.rkt
View File

@ -342,13 +342,15 @@
(raise-syntax-error #f "expected an identifier" stx #'new-id)) (raise-syntax-error #f "expected an identifier" stx #'new-id))
(unless (identifier? #'orig-id) (unless (identifier? #'orig-id)
(raise-syntax-error #f "expected an identifier" stx #'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 ...))] (let loop ([kwd-args (syntax->list #'(kwd-args ...))]
[pos-blame-party-expr #'(quote-module-path)] [pos-blame-party-expr #'(quote-module-path)]
[srcloc-expr #f]) [srcloc-expr #f]
[name-for-blame #f])
(cond (cond
[(null? kwd-args) (values pos-blame-party-expr [(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 [else
(define kwd (car kwd-args)) (define kwd (car kwd-args))
(cond (cond
@ -358,22 +360,39 @@
stx)) stx))
(loop (cddr kwd-args) (loop (cddr kwd-args)
(cadr kwd-args) (cadr kwd-args)
srcloc-expr)] srcloc-expr
name-for-blame)]
[(equal? (syntax-e kwd) '#:srcloc) [(equal? (syntax-e kwd) '#:srcloc)
(when (null? (cdr kwd-args)) (when (null? (cdr kwd-args))
(raise-syntax-error #f "expected a keyword argument to follow #:srcloc" (raise-syntax-error #f "expected a keyword argument to follow #:srcloc"
stx)) stx))
(loop (cddr kwd-args) (loop (cddr kwd-args)
pos-blame-party-expr 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 [else
(raise-syntax-error #f "expected either the keyword #:pos-source of #:srcloc" (raise-syntax-error
stx #f
(car kwd-args))])]))) "expected one of the keywords #:pos-source, #:srcloc, or #:name-for-blame"
stx
(car kwd-args))])])))
(internal-function-to-be-figured-out #'ctrct (internal-function-to-be-figured-out #'ctrct
#'orig-id #'orig-id
#'orig-id #'orig-id
#'new-id name-for-blame
#'new-id #'new-id
srcloc-expr srcloc-expr
'define-module-boundary-contract 'define-module-boundary-contract