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

add the ability to not track context information in contract violation error messages

Browse Source
This commit is contained in:
Robby Findler 2018-05-03 16:25:08 -05:00
parent ecae427777
commit 143d15eaa5
6 changed files with 149 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1990,13 +1990,16 @@ The @racket[define-struct/contract] form only allows a subset of the
contract-expr
pos-blame-party
source-loc
name-for-blame)
name-for-blame
no-context)
#:grammar ([pos-blame-party (code:line)
(code:line #:pos-source pos-source-expr)]
[source-loc (code:line)
(code:line #:srcloc srcloc-expr)]
[name-for-blame (code:line)
(code:line #:name-for-blame blame-id)])]{
(code:line #:name-for-blame blame-id)]
[name-for-blame (code:line)
(code:line #:no-context)])]{
Defines @racket[id] to be @racket[orig-id], but with the contract
@racket[contract-expr].
@ -2019,7 +2022,12 @@ The @racket[define-struct/contract] form only allows a subset of the
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.
If @racket[#:no-context] is supplied, the error message do
not include the context information that indicates which
sub-portion of the contract where the violation was
detected.
@examples[#:eval (contract-eval) #:once
(module server racket/base
(require racket/contract/base)
@ -2041,6 +2049,9 @@ The @racket[define-struct/contract] form only allows a subset of the
@defform*[[(contract contract-expr to-protect-expr
positive-blame-expr negative-blame-expr)
(contract contract-expr to-protect-expr
positive-blame-expr negative-blame-expr
#:no-context)
(contract contract-expr to-protect-expr
positive-blame-expr negative-blame-expr
value-name-expr source-location-expr)]]{
@ -2076,6 +2087,10 @@ reported by contract violations. The expression must produce a @racket[srcloc]
structure, @tech{syntax object}, @racket[#f], or a list or vector in the format
accepted by the third argument to @racket[datum->syntax].
If @racket[#:no-context] is supplied, the error message do not include
the context information that indicates which sub-portion of the contract
where the violation was detected.
}
@; ------------------------------------------------------------------------

13
pkgs/racket-test/tests/racket/contract/blame.rkt
View File

@ -329,4 +329,17 @@
(blame-add-context b "thing" #:important 'yes!)))
#t)
(test/spec-passed/result
'blame-no-context
;; when the "in" has the contract after it, there is no context
'(regexp-match? #rx"in: [(]list/c"
(with-handlers ([exn:fail? exn-message])
((car (contract (list/c (-> integer? integer?))
(list (λ (x) x))
'pos
'neg
#:no-context))
#f)))
#t)
)

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

@ -1588,6 +1588,49 @@
(λ (x)
(and (exn:fail:contract:blame? x)
(regexp-match? #rx"^my-favorite-name: " (exn-message x)))))
(contract-error-test
'define-module-boundary-contract6
'(begin
(eval '(module define-module-boundary-contract6-m racket/base
(require racket/contract/base)
(define internal-name (list (λ (x) #f)))
(define-module-boundary-contract external-name
internal-name (list/c (-> integer? integer?))
#:pos-source 'pos
#:name-for-blame my-favorite-name
#:no-context)
(provide external-name)))
(eval '(module define-module-boundary-contract6-n racket/base
(require 'define-module-boundary-contract6-m)
((car external-name) #f)))
(eval '(require 'define-module-boundary-contract6-n)))
(λ (x)
(and (exn:fail:contract:blame? x)
;; ensure there is no context information
(regexp-match? #rx"in: [(]list/c" (exn-message x))
(regexp-match? #rx"blaming: [^\n]*contract6-n" (exn-message x)))))
(contract-error-test
'define-module-boundary-contract7
'(begin
(eval '(module define-module-boundary-contract7-m racket/base
(require racket/contract/base)
(define internal-name (list (λ (x) #f)))
(define-module-boundary-contract external-name
internal-name (list/c (-> integer? integer?))
#:pos-source 'pos
#:name-for-blame my-favorite-name)
(provide external-name)))
(eval '(module define-module-boundary-contract7-n racket/base
(require 'define-module-boundary-contract7-m)
((car external-name) #f)))
(eval '(require 'define-module-boundary-contract7-n)))
(λ (x)
(and (exn:fail:contract:blame? x)
;; ensure there is context information
(regexp-match? #rx"in: the 1st argument of" (exn-message x))
(regexp-match? #rx"blaming: [^\n]*contract7-n" (exn-message x)))))
(contract-error-test

21
racket/collects/racket/contract/private/base.rkt
View File

@ -42,19 +42,21 @@
(syntax-case stx ()
[(_ c v pos neg name loc)
(syntax/loc stx
(apply-contract c v pos neg name loc))]
(apply-contract c v pos neg name loc #t))]
[(_ c v pos neg)
(with-syntax ([name (syntax-local-infer-name stx)])
(syntax/loc stx
(apply-contract c v pos neg 'name
(build-source-location #f))))]
[(_ c v pos neg src)
(raise-syntax-error 'contract
(string-append
"please update contract application to new protocol "
"(either 4 or 6 arguments)"))]))
(build-source-location #f)
#t)))]
[(_ c v pos neg #:no-context)
(with-syntax ([name (syntax-local-infer-name stx)])
(syntax/loc stx
(apply-contract c v pos neg 'name
(build-source-location #f)
#f)))]))
(define (apply-contract c v pos neg name loc)
(define (apply-contract c v pos neg name loc track-context?)
(let ([c (coerce-contract 'contract c)])
(check-source-location! 'contract loc)
(define clnp (contract-late-neg-projection c))
@ -72,7 +74,8 @@
(or pos "false")
(if clnp #f neg)
#t))
#t
#:track-context? track-context?))
(cond
[clnp (with-contract-continuation-mark
(cons blame neg)

51
racket/collects/racket/contract/private/blame.rkt
View File

@ -65,7 +65,8 @@
(define -make-blame
(let ([make-blame
(lambda (source value build-name positive negative original?)
(lambda (source value build-name positive negative original?
#:track-context? [track-context? #t])
(unless (srcloc? source)
(raise-argument-error 'make-blame "srcloc?" 0
source value build-name positive negative original?))
@ -90,7 +91,7 @@
(list positive)
(and negative (list negative))
original?
'()
(if track-context? '() #f)
#t
#f
(not negative)
@ -99,27 +100,39 @@
;; s : (or/c string? #f)
(define (blame-add-context b s #:important [name #f] #:swap? [swap? #f])
(define new-original? (if swap? (not (blame-original? b)) (blame-original? b)))
(define new-context (if s (cons s (blame-context b)) (blame-context b)))
(struct-copy
blame b
[original? new-original?]
[positive (if swap? (blame-negative b) (blame-positive b))]
[negative (if swap? (blame-positive b) (blame-negative b))]
[important (if name (important name new-original?) (blame-important b))]
[context new-context]
[top-known? #t]))
(cond
[(and (not (blame-context b))
(not swap?)
(not name)
(blame-top-known? b))
b]
[else
(define new-original? (if swap? (not (blame-original? b)) (blame-original? b)))
(define new-context (if (and s (blame-context b))
(cons s (blame-context b))
(blame-context b)))
(struct-copy
blame b
[original? new-original?]
[positive (if swap? (blame-negative b) (blame-positive b))]
[negative (if swap? (blame-positive b) (blame-negative b))]
[important (if name (important name new-original?) (blame-important b))]
[context new-context]
[top-known? #t])]))
(struct important (name sense-swapped?) #:transparent)
(define (blame-add-unknown-context b)
(define old (blame-context b))
(struct-copy
blame b
[top-known? #f]
[context (if (blame-top-known? b)
(blame-context b)
(cons "..." (blame-context b)))]))
(cond
[old
(struct-copy
blame b
[top-known? #f]
[context (if (blame-top-known? b)
(blame-context b)
(cons "..." (blame-context b)))])]
[else b]))
(define (blame-contract b) ((blame-build-name b)))
@ -287,7 +300,7 @@
(define source-message (source-location->string (blame-source blme)))
(define context (blame-context blme))
(define context-lines (if (null? context)
(define context-lines (if (or (null? context) (not context))
#f
(apply string-append
(for/list ([context (in-list context)]

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

@ -259,7 +259,8 @@
id-rename
(stx->srcloc-expr srcloc-id)
'provide/contract
pos-module-source)
pos-module-source
#t)
#,@(if provide?
(list #`(provide (rename-out [#,id-rename external-name])))
null)))
@ -279,7 +280,8 @@
id-rename
srcloc-expr
contract-error-name
pos-module-source)
pos-module-source
track-context?)
(define-values (arrow? the-valid-app-shapes)
(syntax-case ctrct (-> ->* ->i)
[(-> . _)
@ -306,7 +308,8 @@
id
'#,name-for-blame
#,pos-module-source
#,srcloc-expr))
#,srcloc-expr
'#,track-context?))
#,@(if arrow?
(list #`(define extra-neg-party-argument-fn
(wrapped-extra-arg-arrow-extra-neg-party-argument
@ -351,15 +354,17 @@
(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 name-for-blame)
(define-values (pos-blame-party-expr srcloc-expr name-for-blame track-context?)
(let loop ([kwd-args (syntax->list #'(kwd-args ...))]
[pos-blame-party-expr #'(quote-module-path)]
[srcloc-expr #f]
[name-for-blame #f])
[name-for-blame #f]
[track-context? #t])
(cond
[(null? kwd-args) (values pos-blame-party-expr
(or srcloc-expr (stx->srcloc-expr stx))
(or name-for-blame #'new-id))]
(or name-for-blame #'new-id)
track-context?)]
[else
(define kwd (car kwd-args))
(cond
@ -370,7 +375,8 @@
(loop (cddr kwd-args)
(cadr kwd-args)
srcloc-expr
name-for-blame)]
name-for-blame
track-context?)]
[(equal? (syntax-e kwd) '#:srcloc)
(when (null? (cdr kwd-args))
(raise-syntax-error #f "expected a keyword argument to follow #:srcloc"
@ -378,7 +384,8 @@
(loop (cddr kwd-args)
pos-blame-party-expr
(cadr kwd-args)
name-for-blame)]
name-for-blame
track-context?)]
[(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"
@ -391,11 +398,20 @@
(loop (cddr kwd-args)
pos-blame-party-expr
srcloc-expr
name-for-blame)]
name-for-blame
track-context?)]
[(equal? (syntax-e kwd) '#:no-context)
(loop (cdr kwd-args)
pos-blame-party-expr
srcloc-expr
name-for-blame
#f)]
[else
(raise-syntax-error
#f
"expected one of the keywords #:pos-source, #:srcloc, or #:name-for-blame"
(string-append
"expected one of the keywords"
" #:pos-source, #:srcloc, #:name-for-blame, or #:no-context")
stx
(car kwd-args))])])))
(internal-function-to-be-figured-out #'ctrct
@ -405,10 +421,11 @@
#'new-id
srcloc-expr
'define-module-boundary-contract
pos-blame-party-expr))])]))
pos-blame-party-expr
track-context?))])]))
;; ... -> (values (or/c #f (-> neg-party val)) blame)
(define (do-partial-app ctc val name pos-module-source source)
(define (do-partial-app ctc val name pos-module-source source track-context?)
(define p (parameterize ([warn-about-val-first? #f])
;; when we're building the val-first projection
;; here we might be needing the plus1 arity
@ -419,7 +436,8 @@
name
(λ () (contract-name ctc))
pos-module-source
#f #t))
#f #t
#:track-context? track-context?))
(with-contract-continuation-mark
(cons blme 'no-negative-party) ; we don't know the negative party yet
;; computing neg-accepter may involve some front-loaded checking. instrument