From efb96c97b5064b76975f596081fdbf4c53611bb4 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 3 Jan 2017 07:10:30 -0600 Subject: [PATCH] add #:name-for-blame to define-module-boundary-contract --- .../scribblings/reference/contracts.scrbl | 13 ++++++- .../tests/racket/contract/contract-out.rkt | 19 ++++++++++ .../racket/contract/private/provide.rkt | 37 ++++++++++++++----- 3 files changed, 58 insertions(+), 11 deletions(-) diff --git a/pkgs/racket-doc/scribblings/reference/contracts.scrbl b/pkgs/racket-doc/scribblings/reference/contracts.scrbl index 82953c596f..abc68e798b 100644 --- a/pkgs/racket-doc/scribblings/reference/contracts.scrbl +++ b/pkgs/racket-doc/scribblings/reference/contracts.scrbl @@ -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 diff --git a/pkgs/racket-test/tests/racket/contract/contract-out.rkt b/pkgs/racket-test/tests/racket/contract/contract-out.rkt index 4f2e3ff799..c13dd6e1b6 100644 --- a/pkgs/racket-test/tests/racket/contract/contract-out.rkt +++ b/pkgs/racket-test/tests/racket/contract/contract-out.rkt @@ -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 diff --git a/racket/collects/racket/contract/private/provide.rkt b/racket/collects/racket/contract/private/provide.rkt index 6c1b095294..c301b37bce 100644 --- a/racket/collects/racket/contract/private/provide.rkt +++ b/racket/collects/racket/contract/private/provide.rkt @@ -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