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

streamline the representation of blame objects

Browse Source 
and improve the context tracking support
to allow a choice of how much context to save
This commit is contained in:
Robby Findler 2018-05-12 10:20:51 -05:00
parent cd0350c883
commit 0b3f4b627e
12 changed files with 416 additions and 182 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1999,7 +1999,7 @@ The @racket[define-struct/contract] form only allows a subset of the
[name-for-blame (code:line) [name-for-blame (code:line)
(code:line #:name-for-blame blame-id)] (code:line #:name-for-blame blame-id)]
[name-for-blame (code:line) [name-for-blame (code:line)
(code:line #:no-context)])]{ (code:line #:context-limit limit-expr)])]{
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].
@ -2023,10 +2023,8 @@ The @racket[define-struct/contract] form only allows a subset of the
@racket[#:name-for-blame] is supplied, in which case the identifier @racket[#:name-for-blame] is supplied, in which case the identifier
following it is used as the name in the error messages. following it is used as the name in the error messages.
If @racket[#:no-context] is supplied, the error message do If @racket[#:context-limit] is supplied, it behaves the same as
not include the context information that indicates which it does when supplied to @racket[contract].
sub-portion of the contract where the violation was
detected.
@examples[#:eval (contract-eval) #:once @examples[#:eval (contract-eval) #:once
(module server racket/base (module server racket/base
@ -2043,7 +2041,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.}] @history[#:changed "6.7.0.4" @elem{Added the @racket[#:name-for-blame] argument.}
#:changed "6.90.0.29" @elem{Added the @racket[#:context-limit] argument.}]
} }
@ -2051,7 +2050,7 @@ The @racket[define-struct/contract] form only allows a subset of the
positive-blame-expr negative-blame-expr) positive-blame-expr negative-blame-expr)
(contract contract-expr to-protect-expr (contract contract-expr to-protect-expr
positive-blame-expr negative-blame-expr positive-blame-expr negative-blame-expr
#:no-context) #:context-limit limit-expr)
(contract contract-expr to-protect-expr (contract contract-expr to-protect-expr
positive-blame-expr negative-blame-expr positive-blame-expr negative-blame-expr
value-name-expr source-location-expr)]]{ value-name-expr source-location-expr)]]{
@ -2087,9 +2086,13 @@ 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 structure, @tech{syntax object}, @racket[#f], or a list or vector in the format
accepted by the third argument to @racket[datum->syntax]. accepted by the third argument to @racket[datum->syntax].
If @racket[#:no-context] is supplied, the error message do not include If @racket[#:context-limit] is supplied, the following expression
the context information that indicates which sub-portion of the contract must evaluate to either @racket[#f] or a natural number. If
where the violation was detected. the expression evaluates to an natural number, the number of
layers of context information is limited to at most that
many. For example, if the number is @racket[0], no context
information is recorded and the error messages do not contain
the section that starts with @litchar{in:}.
} }
@ -2532,6 +2535,12 @@ passing @racket[#f] as the context string argument avoids adding the
@racket["..."] string. @racket["..."] string.
} }
@defproc[(blame-context [blame blame?]) (listof string?)]{
Returns the context information that would be supplied in
an error message, if @racket[blame] is passed to @racket[raise-blame-error].
}
@deftogether[( @deftogether[(
@defproc[(blame-positive [b blame?]) any/c] @defproc[(blame-positive [b blame?]) any/c]
@defproc[(blame-negative [b blame?]) any/c] @defproc[(blame-negative [b blame?]) any/c]

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

@ -126,6 +126,57 @@
'neg2) 'neg2)
'no-exn-raised) 'no-exn-raised)
#t) #t)
(test/spec-passed/result
'blame-selector.16
'(blame-context
(blame-add-context
(blame-add-context
(blame-add-context
(blame-add-context
(blame-add-context
(make-blame (srcloc "src.rkt" #f #f #f #f)
'whatever (λ () 'the-name) 'pos #f #t)
"1")
"2")
"3")
"4")
"5"))
'("5" "4" "3" "2" "1"))
(test/spec-passed/result
'blame-selector.17
'(blame-context
(blame-add-context
(blame-add-context
(blame-add-context
(blame-add-context
(blame-add-context
(make-blame (srcloc "src.rkt" #f #f #f #f)
'whatever (λ () 'the-name) 'pos 'neg #t
#:context-limit 2)
"1")
"2")
"3")
"4")
"5"))
'("5" "4"))
(test/spec-passed/result
'blame-selector.18
'(blame-positive
(blame-add-context
(blame-add-context
(blame-add-context
(blame-add-context
(blame-add-context
(blame-swap
(make-blame (srcloc "src.rkt" #f #f #f #f)
'whatever (λ () 'the-name) 'pos 'neg #t
#:context-limit 2))
"1")
"2")
"3")
"4")
"5"))
'neg)
(contract-eval (contract-eval
#:test-case-name "blame.rkt setup.1" #:test-case-name "blame.rkt setup.1"
@ -392,12 +443,26 @@
'blame-no-context 'blame-no-context
;; when the "in" has the contract after it, there is no context ;; when the "in" has the contract after it, there is no context
'(regexp-match? #rx"in: [(]list/c" '(regexp-match? #rx"in: [(]list/c"
(with-handlers ([exn:fail? exn-message]) (with-handlers ([exn:fail:contract:blame? exn-message])
((car (contract (list/c (-> integer? integer?)) ((car (contract (list/c (-> integer? integer?))
(list (λ (x) x)) (list (λ (x) x))
'pos 'pos
'neg 'neg
#:no-context)) #:limit-context 0))
#f)))
#t)
(test/spec-passed/result
'blame-1-context
;; make sure that, when there is one frame of context,
;; we do not see the `list/c` part of the context
'(regexp-match? #rx"element of"
(with-handlers ([exn:fail:contract:blame? exn-message])
((car (contract (list/c (-> integer? integer?))
(list (λ (x) x))
'pos
'neg
#:limit-context 10))
#f))) #f)))
#t) #t)

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

@ -1599,7 +1599,7 @@
internal-name (list/c (-> integer? integer?)) internal-name (list/c (-> integer? integer?))
#:pos-source 'pos #:pos-source 'pos
#:name-for-blame my-favorite-name #:name-for-blame my-favorite-name
#:no-context) #:context-limit 0)
(provide external-name))) (provide external-name)))
(eval '(module define-module-boundary-contract6-n racket/base (eval '(module define-module-boundary-contract6-n racket/base
(require 'define-module-boundary-contract6-m) (require 'define-module-boundary-contract6-m)

7
racket/collects/racket/contract/private/arrow-common.rkt
View File

@ -349,8 +349,8 @@
#:missing-party [missing-party #f]) #:missing-party [missing-party #f])
(define num-values (length results)) (define num-values (length results))
(define blame-case (if case-context (define blame-case (if case-context
(blame-add-context blame (format "the ~a case of" (blame-add-context blame
(n->th (+ case-context 1)))) (nth-case-of (+ case-context 1)))
blame)) blame))
(raise-blame-error (blame-add-range-context blame-case) (raise-blame-error (blame-add-range-context blame-case)
#:missing-party missing-party #:missing-party missing-party
@ -360,8 +360,7 @@
num-values (if (= num-values 1) "" "s"))) num-values (if (= num-values 1) "" "s")))
(define (blame-add-nth-arg-context blame n) (define (blame-add-nth-arg-context blame n)
(blame-add-context blame (blame-add-context blame (nth-argument-of n)))
(format "the ~a argument of" (n->th n))))
(define (raise-wrong-number-of-args-error (define (raise-wrong-number-of-args-error
blame #:missing-party [missing-party #f] val blame #:missing-party [missing-party #f] val

2
racket/collects/racket/contract/private/arrow-higher-order.rkt
View File

@ -560,7 +560,7 @@
[n (in-naturals 1)]) [n (in-naturals 1)])
((get/build-late-neg-projection dom) ((get/build-late-neg-projection dom)
(blame-add-context orig-blame (blame-add-context orig-blame
(format "the ~a argument of" (n->th (if method? (sub1 n) n))) (nth-argument-of (if method? (sub1 n) n))
#:swap? #t)))) #:swap? #t))))
(define rest-blame (define rest-blame
(if (ellipsis-rest-arg-ctc? rest) (if (ellipsis-rest-arg-ctc? rest)

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

@ -39,24 +39,35 @@
(quasisyntax/loc stx (#%expression #,stx))))) (quasisyntax/loc stx (#%expression #,stx)))))
(define-syntax (contract stx) (define-syntax (contract stx)
(let ([l (syntax->list stx)])
(when l
(for ([thing (in-list (cdr (syntax->list stx)))])
(when (keyword? (syntax-e thing))
(unless (equal? (syntax-e thing) '#:limit-context)
(raise-syntax-error 'contract
(format "did not expect keyword ~a" (syntax-e thing))
stx
thing))))))
(syntax-case stx () (syntax-case stx ()
[(_ c v pos neg name loc) [(_ c v pos neg #:limit-context limit-context-expression)
(syntax/loc stx
(apply-contract c v pos neg name loc #t))]
[(_ c v pos neg)
(with-syntax ([name (syntax-local-infer-name stx)]) (with-syntax ([name (syntax-local-infer-name stx)])
(syntax/loc stx (syntax/loc stx
(apply-contract c v pos neg 'name (apply-contract c v pos neg 'name
(build-source-location #f) (build-source-location #f)
#t)))] limit-context-expression)))]
[(_ c v pos neg #:no-context) [(_ c v pos neg name loc)
(syntax/loc stx
(apply-contract c v pos neg name loc #f))]
[(_ c v pos neg)
(with-syntax ([name (syntax-local-infer-name stx)]) (with-syntax ([name (syntax-local-infer-name stx)])
(syntax/loc stx (syntax/loc stx
(apply-contract c v pos neg 'name (apply-contract c v pos neg 'name
(build-source-location #f) (build-source-location #f)
#f)))])) #f)))]))
(define (apply-contract c v pos neg name loc track-context?) (define (apply-contract c v pos neg name loc context-limit)
(let ([c (coerce-contract 'contract c)]) (let ([c (coerce-contract 'contract c)])
(check-source-location! 'contract loc) (check-source-location! 'contract loc)
(define clnp (contract-late-neg-projection c)) (define clnp (contract-late-neg-projection c))
@ -75,7 +86,7 @@
(if clnp #f neg) (if clnp #f neg)
#t #t
#:track-context? track-context?)) #:context-limit context-limit))
(cond (cond
[clnp (with-contract-continuation-mark [clnp (with-contract-continuation-mark
(cons blame neg) (cons blame neg)

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

@ -31,48 +31,92 @@
(define invariant-assertion-party (string->uninterned-symbol "invariant-assertion")) (define invariant-assertion-party (string->uninterned-symbol "invariant-assertion"))
(define (blame=? a b equal?/recur) (define (blame=? a b equal?/recur)
(and (equal?/recur (blame-positive a) (blame-positive b)) (and (or (and (blame-no-swap? a) (blame-no-swap? b))
(equal?/recur (blame-negative a) (blame-negative b)) (and (blame-yes-swap? a) (blame-yes-swap? b)))
(equal?/recur (blame-original? a) (blame-original? b)) (equal?/recur (blame-context-frame a) (blame-context-frame b))
(equal?/recur (blame-more-stuff a) (blame-more-stuff b)))) (equal?/recur (blame-and-more a) (blame-and-more b))))
(define (combine-them . args) (define (combine-them x y)
(let loop ([args args]) (bitwise-xor x (* 3 y)))
(cond
[(null? (cdr args)) (car args)]
[else (bitwise-xor (car args) (* 3 (loop (cdr args))))])))
(define (blame-hash b hash/recur) (define (blame-hash b hash/recur)
(combine-them (hash/recur (blame-positive b)) (combine-them (hash/recur (blame-no-swap? b))
(hash/recur (blame-negative b)) (combine-them (hash/recur (blame-context-frame b))
(hash/recur (blame-original? b)) (hash/recur (blame-and-more b)))))
(hash/recur (blame-more-stuff b))))
;; missing-party? field is #t when the missing party ;; missing-party? field is #t when the missing party
;; is still missing and it is #f when the missing party ;; is still missing and it is #f when the missing party
;; has been filled in (or if it was filled in from the start) ;; has been filled in (or if it was filled in from the start)
(define-struct more-stuff (define-struct all-the-info
[source value build-name context top-known? important missing-party? extra-fields] [positive
negative
source value build-name top-known? important missing-party? context-limit extra-fields]
#:transparent) #:transparent)
(define-struct blame ;; and-more : (or/c blame-no-swap? blame-swap? all-the-info?)
(positive negative original? [swapped #:mutable] more-stuff) ;; context : string?
(define-struct blame (context-frame and-more)
#:property prop:equal+hash #:property prop:equal+hash
(list blame=? blame-hash blame-hash)) (list blame=? blame-hash blame-hash))
(define (blame-source b) (more-stuff-source (blame-more-stuff b))) (define-struct (blame-no-swap blame) ()
(define (blame-value b) (more-stuff-value (blame-more-stuff b))) #:property prop:equal+hash
(define (blame-context b) (more-stuff-context (blame-more-stuff b))) (list blame=? blame-hash blame-hash))
(define (blame-top-known? b) (more-stuff-top-known? (blame-more-stuff b))) (define-struct (blame-yes-swap blame) ()
(define (blame-important b) (more-stuff-important (blame-more-stuff b))) #:property prop:equal+hash
(define (blame-missing-party? b) (more-stuff-missing-party? (blame-more-stuff b))) (list blame=? blame-hash blame-hash))
(define (blame-contract b) ((more-stuff-build-name (blame-more-stuff b))))
(define (blame-extra-fields b) (more-stuff-extra-fields (blame-more-stuff b))) (define (blame->all-the-info b)
(let loop ([b b])
(cond
[(blame? b) (loop (blame-and-more b))]
[else b])))
(define (blame-source b) (all-the-info-source (blame->all-the-info b)))
(define (blame-value b) (all-the-info-value (blame->all-the-info b)))
(define (blame-top-known? b) (all-the-info-top-known? (blame->all-the-info b)))
(define (blame-important b) (all-the-info-important (blame->all-the-info b)))
(define (blame-missing-party? b) (all-the-info-missing-party? (blame->all-the-info b)))
(define (blame-contract b) ((all-the-info-build-name (blame->all-the-info b))))
(define (blame-extra-fields b) (all-the-info-extra-fields (blame->all-the-info b)))
(define (blame-context-limit b) (all-the-info-context-limit (blame->all-the-info b)))
(define (blame-get-info b f)
(let loop ([b b]
[swapped? #f])
(cond
[(blame-yes-swap? b) (loop (blame-and-more b) (not swapped?))]
[(blame-no-swap? b) (loop (blame-and-more b) swapped?)]
[else (f b swapped?)])))
(define (blame-original? b) (blame-get-info b (λ (all-the-info swapped?) (not swapped?))))
(define (blame-swapped? b) (blame-get-info b (λ (all-the-info swapped?) swapped?)))
(define (blame-positive b)
(blame-get-info b (λ (all-the-info swapped?)
(if swapped?
(all-the-info-negative all-the-info)
(all-the-info-positive all-the-info)))))
(define (blame-negative b)
(blame-get-info b (λ (all-the-info swapped?)
(if swapped?
(all-the-info-positive all-the-info)
(all-the-info-negative all-the-info)))))
(define (blame-context b)
(let loop ([top (blame-context-frame b)]
[b (blame-and-more b)])
(cond
[(all-the-info? b)
;; there is a dummy #f at the end
;; but it might be dropped if the
;; context is limited, so we don't
;; include it in the list
(if top (list top) '())]
[else (cons top (loop (blame-context-frame b)
(blame-and-more b)))])))
(define -make-blame (define -make-blame
(let ([make-blame (let ([make-blame
(λ (source value build-name positive negative original? (λ (source value build-name positive negative original?
#:track-context? [track-context? #t]) #:context-limit [context-limit #f])
(unless (srcloc? source) (unless (srcloc? source)
(raise-argument-error 'make-blame "srcloc?" 0 (raise-argument-error 'make-blame "srcloc?" 0
source value build-name positive negative original?)) source value build-name positive negative original?))
@ -83,6 +127,11 @@
(unless positive (unless positive
(raise-type-error 'make-blame "(not/c #f)" 3 (raise-type-error 'make-blame "(not/c #f)" 3
source value build-name positive negative original?)) source value build-name positive negative original?))
(unless (or (not context-limit)
(exact-nonnegative-integer? context-limit))
(raise-argument-error 'make-blame
(format "~s" '(or/c #f natural?))
context-limit))
(define build/memo-name (define build/memo-name
(let* ([uniq (box #f)] (let* ([uniq (box #f)]
[ans uniq]) [ans uniq])
@ -90,46 +139,27 @@
(when (eq? uniq ans) (when (eq? uniq ans)
(set! ans (build-name))) (set! ans (build-name)))
ans))) ans)))
(define more-stuff (define all-the-info
(make-more-stuff (make-all-the-info
(list positive)
(and negative (list negative))
source source
value value
build/memo-name build/memo-name
(if track-context? '() #f)
#t #t
#f #f
(not negative) (not negative)
context-limit
'())) '()))
(new-blame (list positive) ;; we always start with a yes-swap or no-swap struct
(and negative (list negative)) ;; so be careful in other parts of the code to ignore
original? ;; it, as appropriate.
more-stuff))]) (if original?
(blame-no-swap/intern #f all-the-info)
(blame-yes-swap/intern #f all-the-info)))])
make-blame)) make-blame))
(define (new-blame/more-stuff b more-stuff) (define seen '())
(new-blame (blame-positive b)
(blame-negative b)
(blame-original? b)
more-stuff))
(define (new-blame poss negs original? more-stuff)
(define original-blame
(make-blame
poss
negs
original?
#f
more-stuff))
(define swapped-blame
(make-blame
negs
poss
(not original?)
original-blame
more-stuff))
(set-blame-swapped! original-blame swapped-blame)
original-blame)
(define (blame-add-context b s #:important [name #f] #:swap? [swap? #f]) (define (blame-add-context b s #:important [name #f] #:swap? [swap? #f])
(unless (blame? b) (unless (blame? b)
(raise-argument-error 'blame-add-context (raise-argument-error 'blame-add-context
@ -147,55 +177,164 @@
(define (blame-add-unknown-context b) (define (blame-add-unknown-context b)
(do-blame-add-context b #f #f #f)) (do-blame-add-context b #f #f #f))
(define (make-blame-yes/no-swap/intern blame-yes/no-swap)
(define ht (make-hash))
(define (blame-yes/no-swap/intern s b)
(define b-table (hash-ref! ht s make-hash))
(hash-ref! b-table b (λ () (blame-yes/no-swap s b))))
blame-yes/no-swap/intern)
(define blame-no-swap/intern (make-blame-yes/no-swap/intern blame-no-swap))
(define blame-yes-swap/intern (make-blame-yes/no-swap/intern blame-yes-swap))
(define (do-blame-add-context b s name swap?) (define (do-blame-add-context b s name swap?)
(define context-limit (blame-context-limit b))
(cond (cond
[(and (not (blame-context b)) [(and context-limit
;; if we are not tracking context, ;; if we are not tracking context,
;; we are not updating the name ;; we are not updating the name
;; at the top of the messages either ;; at the top of the messages either
; (not name) ; (not name)
(blame-top-known? b)) (blame-top-known? b))
(if swap? (blame-swap b) b)] (cond
[(and s (not (zero? context-limit)))
;; if the limit is zero, we skip this case,
;; which has the effect of always keeping only
;; the dummy context frame
(define-values (limited-b dropped-swap?) (drop-to-limit b context-limit))
(if (equal? dropped-swap? swap?)
(blame-no-swap/intern s limited-b)
(blame-yes-swap/intern s limited-b))]
[swap?
(if (blame-yes-swap? b)
(blame-no-swap/intern (blame-context-frame b) (blame-and-more b))
(blame-yes-swap/intern (blame-context-frame b) (blame-and-more b)))]
[else b])]
[else [else
(define blame-yes/no-swap (if swap? blame-yes-swap/intern blame-no-swap/intern))
(define inside-part
(let/ec k
(let loop ([inner-b b])
(cond
[(blame-yes-swap? inner-b)
(blame-yes-swap/intern (blame-context-frame inner-b) (loop (blame-and-more inner-b)))]
[(blame-no-swap? inner-b)
(blame-no-swap/intern (blame-context-frame inner-b) (loop (blame-and-more inner-b)))]
[else
(define top-known? (all-the-info-top-known? inner-b))
(cond
[(or (equal? top-known? (string? s))
name)
(define new-original? (if swap? (not (blame-original? b)) (blame-original? b))) (define new-original? (if swap? (not (blame-original? b)) (blame-original? b)))
(define new-context (if (and s (blame-context b)) ;; in this case, we need to make a new blame record
(cons s (blame-context b))
(blame-context b)))
(define new-context/maybe-unknown
(if (or s (blame-top-known? b))
new-context
(cons "..." new-context)))
(define maybe-swapped (if swap? (blame-swap b) b))
(new-blame/more-stuff
maybe-swapped
(struct-copy (struct-copy
more-stuff (blame-more-stuff b) all-the-info inner-b
[important (if name (important name new-original?) (blame-important b))] [important (if name
[context new-context/maybe-unknown] (important name new-original?)
[top-known? (string? s)]))])) (all-the-info-important inner-b))]
[top-known? (string? s)])]
[else
;; we can skip all that pending work
;; of making a copy in this case
(k b)])]))))
(if swap?
(blame-yes-swap/intern s inside-part)
(blame-no-swap/intern s inside-part))]))
(define (drop-to-limit b context-limit)
(define short-enough?
(let loop ([b b]
[n (- context-limit 1)])
(cond
[(all-the-info? b) #t]
[(blame? b)
(if (zero? n)
#f
(loop (blame-and-more b) (- n 1)))])))
(cond
[short-enough? (values b #f)]
[else
(define swapped? #f)
(define limited-b
(let loop ([b b]
[n (- context-limit 1)])
(cond
[(= n 0)
(let loop ([b b]
[swap? #f])
(cond
[(blame-yes-swap? b) (loop (blame-and-more b) (not swap?))]
[(blame-no-swap? b) (loop (blame-and-more b) swap?)]
[else
(set! swapped? swap?)
b]))]
[(blame-no-swap? b)
(blame-no-swap/intern (blame-context-frame b)
(loop (blame-and-more b) (- n 1)))]
[(blame-yes-swap? b)
(blame-yes-swap/intern (blame-context-frame b)
(loop (blame-and-more b) (- n 1)))])))
(values limited-b swapped?)]))
(struct important (name sense-swapped?) #:transparent) (struct important (name sense-swapped?) #:transparent)
(define (blame-swap b) (blame-swapped b)) (define (blame-swap b)
(cond
[(blame-yes-swap? b)
(blame-no-swap/intern (blame-context-frame b) (blame-and-more b))]
[(blame-no-swap? b)
(blame-yes-swap/intern (blame-context-frame b) (blame-and-more b))]))
(define (blame-replace-negative b new-neg) (define (blame-replace-negative b new-neg)
(new-blame (blame-positive b) (update-the-info
(list new-neg) b
(blame-original? b) (λ (an-all-the-info swap?)
(blame-more-stuff b))) (if swap?
(all-the-info-replace-positive an-all-the-info new-neg)
(all-the-info-replace-negative an-all-the-info new-neg)))))
(define (blame-replace-positive b new-pos) (define (blame-replace-positive b new-pos)
(new-blame (list new-pos) (update-the-info
(blame-negative b) b
(blame-original? b) (λ (an-all-the-info swap?)
(blame-more-stuff b))) (if swap?
(all-the-info-replace-negative an-all-the-info new-pos)
(all-the-info-replace-positive an-all-the-info new-pos)))))
(define (all-the-info-replace-positive an-all-the-info new-pos)
(struct-copy
all-the-info an-all-the-info
[positive (list new-pos)]))
(define (all-the-info-replace-negative an-all-the-info new-neg)
(struct-copy
all-the-info an-all-the-info
[negative (list new-neg)]))
(define (blame-update b extra-positive extra-negative) (define (blame-update b extra-positive extra-negative)
(ensure-blame-known 'blame-update b) (ensure-blame-known 'blame-update b)
(new-blame (cons extra-positive (blame-positive b)) (update-the-info
(cons extra-negative (blame-negative b)) b
(blame-original? b) (λ (an-all-the-info swap?)
(blame-more-stuff b))) (if swap?
(struct-copy
all-the-info an-all-the-info
[positive (cons extra-negative (all-the-info-positive an-all-the-info))]
[negative (cons extra-positive (all-the-info-negative an-all-the-info))])
(struct-copy
all-the-info an-all-the-info
[positive (cons extra-positive (all-the-info-positive an-all-the-info))]
[negative (cons extra-negative (all-the-info-negative an-all-the-info))])))))
(define (update-the-info b f)
(let loop ([b b]
[swap? #f])
(cond
[(blame-yes-swap? b)
(blame-yes-swap/intern (blame-context-frame b) (loop (blame-and-more b) (not swap?)))]
[(blame-no-swap? b)
(blame-no-swap/intern (blame-context-frame b) (loop (blame-and-more b) swap?))]
[else (f b swap?)])))
(define (ensure-blame-known who blame) (define (ensure-blame-known who blame)
(unless (and (blame-positive blame) (unless (and (blame-positive blame)
@ -212,9 +351,6 @@
(define (show-blame-positive b) (show-blame blame-positive b)) (define (show-blame-positive b) (show-blame blame-positive b))
(define (show-blame-negative b) (show-blame blame-negative b)) (define (show-blame-negative b) (show-blame blame-negative b))
(define (blame-swapped? b)
(not (blame-original? b)))
(define-struct (exn:fail:contract:blame exn:fail:contract) [object] (define-struct (exn:fail:contract:blame exn:fail:contract) [object]
#:transparent) #:transparent)
@ -255,32 +391,21 @@
blame))) blame)))
(define (blame-add-missing-party b missing-party) (define (blame-add-missing-party b missing-party)
(cond
(define (check-and-fail) [(not missing-party) b]
[else
(unless (blame-missing-party? b) (unless (blame-missing-party? b)
(error 'blame-add-missing-party "already have the party: ~s; trying to add ~s" (error 'blame-add-missing-party "already have the party: ~s; trying to add ~s"
(if (blame-swapped? b) (blame-positive b) (blame-negative b)) (if (blame-swapped? b) (blame-positive b) (blame-negative b))
missing-party))) missing-party))
(cond (update-the-info
[(not missing-party) b] b
[(blame-swapped? b) (λ (an-all-the-info swap?)
(check-and-fail)
(new-blame (or (blame-positive b)
(list missing-party))
(blame-negative b)
(blame-original? b)
(struct-copy (struct-copy
more-stuff (blame-more-stuff b) all-the-info an-all-the-info
[missing-party? #f]))] [negative (or (all-the-info-negative an-all-the-info)
[else (list missing-party))]
(check-and-fail) [missing-party? #f])))]))
(new-blame (blame-positive b)
(or (blame-negative b)
(list missing-party))
(blame-original? b)
(struct-copy
more-stuff (blame-more-stuff b)
[missing-party? #f]))]))
(define (blame-fmt->-string blame fmt) (define (blame-fmt->-string blame fmt)
(cond (cond
@ -454,12 +579,13 @@
(raise-argument-error 'blame-add-extra-field (raise-argument-error 'blame-add-extra-field
"string?" "string?"
2 b name field)) 2 b name field))
(new-blame/more-stuff (update-the-info
b b
(λ (an-all-the-info swap?)
(struct-copy (struct-copy
more-stuff (blame-more-stuff b) all-the-info an-all-the-info
[extra-fields (cons (format " ~a: ~a" name field) [extra-fields (cons (format " ~a: ~a" name field)
(blame-extra-fields b))]))) (blame-extra-fields b))]))))
;; combine-lines : (-> (listof (or/c string? #f))) string?) ;; combine-lines : (-> (listof (or/c string? #f))) string?)
;; combines each of 'lines' into a single message, dropping #fs, ;; combines each of 'lines' into a single message, dropping #fs,
@ -505,11 +631,9 @@
[(path? x) (path->relative-string/library x)] [(path? x) (path->relative-string/library x)]
[else x])) [else x]))
(define (from-info x) (define (from-info x)
(convert-blame-singleton (last x))) (convert-blame-singleton (last x)))
(define (convert-blame-party x) (define (convert-blame-party x)
(let ((preface (let ((preface
(cond [(< 1 (length x)) (cond [(< 1 (length x))

2
racket/collects/racket/contract/private/case-arrow.rkt
View File

@ -217,7 +217,7 @@
(blame-add-context (blame-add-context
(blame-add-context (blame-add-context
blame blame
(format "the ~a case of" (n->th (+ (car f) 1)))) (nth-case-of (+ (car f) 1)))
"the domain of" "the domain of"
#:swap? #t))) #:swap? #t)))
dom-ctcs+case-nums) dom-ctcs+case-nums)

30
racket/collects/racket/contract/private/guts.rkt
View File

@ -83,6 +83,9 @@
raise-predicate-blame-error-failure raise-predicate-blame-error-failure
n->th n->th
nth-argument-of
nth-element-of
nth-case-of
false/c-contract false/c-contract
true/c-contract true/c-contract
@ -918,6 +921,33 @@
[(3) "rd"] [(3) "rd"]
[else "th"]))) [else "th"])))
(define (nth-element-of/alloc n)
(format "the ~a element of" (n->th n)))
(define (nth-argument-of/alloc n)
(format "the ~a argument of" (n->th n)))
(define (nth-case-of/alloc n)
(format "the ~a case of" (n->th n)))
(define-syntax (define-precompute/simple stx)
(syntax-case stx ()
[(_ fn fn/alloc lower-bound-stx upper-bound-stx)
(let ()
(define lower-bound (syntax-e #'lower-bound-stx))
(define upper-bound (syntax-e #'upper-bound-stx))
(define (n->id n)
(string->symbol (format "precomputed-~a" n)))
#`(begin
#,@(for/list ([i (in-range lower-bound (+ upper-bound 1))])
#`(define #,(n->id i) (fn/alloc #,i)))
(define (fn n)
(case n
#,@(for/list ([i (in-range lower-bound (+ upper-bound 1))])
#`[(#,i) #,(n->id i)])
[else (fn/alloc n)]))))]))
(define-precompute/simple nth-element-of nth-element-of/alloc 0 10)
(define-precompute/simple nth-argument-of nth-argument-of/alloc 1 7)
(define-precompute/simple nth-case-of nth-case-of/alloc 1 2)
(define-syntax-rule (define-syntax-rule
(contract-pos/neg-doubling e1 e2) (contract-pos/neg-doubling e1 e2)

8
racket/collects/racket/contract/private/list.rkt
View File

@ -811,13 +811,7 @@
(expected-a-list val blame #:missing-party neg-party)])))) (expected-a-list val blame #:missing-party neg-party)]))))
(define (add-list-context blame i) (define (add-list-context blame i)
(blame-add-context blame (format "the ~a~a element of" (blame-add-context blame (nth-element-of i)))
i
(case (modulo i 10)
[(1) "st"]
[(2) "nd"]
[(3) "rd"]
[else "th"]))))
(struct chaperone-list/c generic-list/c () (struct chaperone-list/c generic-list/c ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc

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

@ -260,7 +260,7 @@
(stx->srcloc-expr srcloc-id) (stx->srcloc-expr srcloc-id)
'provide/contract 'provide/contract
pos-module-source pos-module-source
#t) #f)
#,@(if provide? #,@(if provide?
(list #`(provide (rename-out [#,id-rename external-name]))) (list #`(provide (rename-out [#,id-rename external-name])))
null))) null)))
@ -281,7 +281,7 @@
srcloc-expr srcloc-expr
contract-error-name contract-error-name
pos-module-source pos-module-source
track-context?) context-limit)
(define-values (arrow? the-valid-app-shapes) (define-values (arrow? the-valid-app-shapes)
(syntax-case ctrct (-> ->* ->i) (syntax-case ctrct (-> ->* ->i)
[(-> . _) [(-> . _)
@ -309,7 +309,7 @@
'#,name-for-blame '#,name-for-blame
#,pos-module-source #,pos-module-source
#,srcloc-expr #,srcloc-expr
'#,track-context?)) #,context-limit))
#,@(if arrow? #,@(if arrow?
(list #`(define extra-neg-party-argument-fn (list #`(define extra-neg-party-argument-fn
(wrapped-extra-arg-arrow-extra-neg-party-argument (wrapped-extra-arg-arrow-extra-neg-party-argument
@ -354,17 +354,17 @@
(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 name-for-blame track-context?) (define-values (pos-blame-party-expr srcloc-expr name-for-blame context-limit)
(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] [name-for-blame #f]
[track-context? #t]) [context-limit #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) (or name-for-blame #'new-id)
track-context?)] context-limit)]
[else [else
(define kwd (car kwd-args)) (define kwd (car kwd-args))
(cond (cond
@ -376,7 +376,7 @@
(cadr kwd-args) (cadr kwd-args)
srcloc-expr srcloc-expr
name-for-blame name-for-blame
track-context?)] context-limit)]
[(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"
@ -385,7 +385,7 @@
pos-blame-party-expr pos-blame-party-expr
(cadr kwd-args) (cadr kwd-args)
name-for-blame name-for-blame
track-context?)] context-limit)]
[(equal? (syntax-e kwd) '#:name-for-blame) [(equal? (syntax-e kwd) '#:name-for-blame)
(when (null? (cdr kwd-args)) (when (null? (cdr kwd-args))
(raise-syntax-error #f "expected a keyword argument to follow #:name-for-blame" (raise-syntax-error #f "expected a keyword argument to follow #:name-for-blame"
@ -399,19 +399,22 @@
pos-blame-party-expr pos-blame-party-expr
srcloc-expr srcloc-expr
name-for-blame name-for-blame
track-context?)] context-limit)]
[(equal? (syntax-e kwd) '#:no-context) [(equal? (syntax-e kwd) '#:context-limit)
(loop (cdr kwd-args) (when (null? (cdr kwd-args))
(raise-syntax-error #f "expected an expression to follow #:context-limit"
stx))
(loop (cddr kwd-args)
pos-blame-party-expr pos-blame-party-expr
srcloc-expr srcloc-expr
name-for-blame name-for-blame
#f)] (cadr kwd-args))]
[else [else
(raise-syntax-error (raise-syntax-error
#f #f
(string-append (string-append
"expected one of the keywords" "expected one of the keywords"
" #:pos-source, #:srcloc, #:name-for-blame, or #:no-context") " #:pos-source, #:srcloc, #:name-for-blame, or #:context-limit")
stx stx
(car kwd-args))])]))) (car kwd-args))])])))
(internal-function-to-be-figured-out #'ctrct (internal-function-to-be-figured-out #'ctrct
@ -422,10 +425,10 @@
srcloc-expr srcloc-expr
'define-module-boundary-contract 'define-module-boundary-contract
pos-blame-party-expr pos-blame-party-expr
track-context?))])])) context-limit))])]))
;; ... -> (values (or/c #f (-> neg-party val)) blame) ;; ... -> (values (or/c #f (-> neg-party val)) blame)
(define (do-partial-app ctc val name pos-module-source source track-context?) (define (do-partial-app ctc val name pos-module-source source context-limit)
(define p (parameterize ([warn-about-val-first? #f]) (define p (parameterize ([warn-about-val-first? #f])
;; when we're building the val-first projection ;; when we're building the val-first projection
;; here we might be needing the plus1 arity ;; here we might be needing the plus1 arity
@ -437,7 +440,7 @@
(λ () (contract-name ctc)) (λ () (contract-name ctc))
pos-module-source pos-module-source
#f #t #f #t
#:track-context? track-context?)) #:context-limit context-limit))
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blme 'no-negative-party) ; we don't know the negative party yet (cons blme 'no-negative-party) ; we don't know the negative party yet
;; computing neg-accepter may involve some front-loaded checking. instrument ;; computing neg-accepter may involve some front-loaded checking. instrument

5
racket/collects/racket/contract/private/vector.rkt
View File

@ -466,13 +466,12 @@
([c (in-list elem-ctcs)] ([c (in-list elem-ctcs)]
[i (in-naturals)]) [i (in-naturals)])
((get/build-late-neg-projection c) ((get/build-late-neg-projection c)
(blame-add-context blame (format "the ~a element of" (n->th i))))) (blame-add-context blame (nth-element-of i))))
(for/vector #:length (length elem-ctcs) (for/vector #:length (length elem-ctcs)
([c (in-list elem-ctcs)] ([c (in-list elem-ctcs)]
[i (in-naturals)]) [i (in-naturals)])
((get/build-late-neg-projection c) ((get/build-late-neg-projection c)
(blame-add-context blame (format "the ~a element of" (n->th i)) (blame-add-context blame (nth-element-of i) #:swap? #t)))))
#:swap? #t)))))
(cond (cond
[filled? [filled?
(λ (val neg-party) (λ (val neg-party)