streamline the representation of blame objects
and improve the context tracking support to allow a choice of how much context to save
This commit is contained in:
Robby Findler
parent
cd0350c883
commit
0b3f4b627e
|
|
@ -1999,7 +1999,7 @@ The @racket[define-struct/contract] form only allows a subset of the
|
|||
[name-for-blame (code:line)
|
||||
(code:line #:name-for-blame blame-id)]
|
||||
[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
|
||||
@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
|
||||
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.
|
||||
If @racket[#:context-limit] is supplied, it behaves the same as
|
||||
it does when supplied to @racket[contract].
|
||||
|
||||
@examples[#:eval (contract-eval) #:once
|
||||
(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 (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)
|
||||
(contract contract-expr to-protect-expr
|
||||
positive-blame-expr negative-blame-expr
|
||||
#:no-context)
|
||||
#:context-limit limit-expr)
|
||||
(contract contract-expr to-protect-expr
|
||||
positive-blame-expr negative-blame-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
|
||||
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.
|
||||
If @racket[#:context-limit] is supplied, the following expression
|
||||
must evaluate to either @racket[#f] or a natural number. If
|
||||
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.
|
||||
}
|
||||
|
||||
@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[(
|
||||
@defproc[(blame-positive [b blame?]) any/c]
|
||||
@defproc[(blame-negative [b blame?]) any/c]
|
||||
|
|
|
|||
|
|
@ -126,6 +126,57 @@
|
|||
'neg2)
|
||||
'no-exn-raised)
|
||||
#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
|
||||
#:test-case-name "blame.rkt setup.1"
|
||||
|
|
@ -392,12 +443,26 @@
|
|||
'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])
|
||||
(with-handlers ([exn:fail:contract:blame? exn-message])
|
||||
((car (contract (list/c (-> integer? integer?))
|
||||
(list (λ (x) x))
|
||||
'pos
|
||||
'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)))
|
||||
#t)
|
||||
|
||||
|
|
|
|||
|
|
@ -1599,7 +1599,7 @@
|
|||
internal-name (list/c (-> integer? integer?))
|
||||
#:pos-source 'pos
|
||||
#:name-for-blame my-favorite-name
|
||||
#:no-context)
|
||||
#:context-limit 0)
|
||||
(provide external-name)))
|
||||
(eval '(module define-module-boundary-contract6-n racket/base
|
||||
(require 'define-module-boundary-contract6-m)
|
||||
|
|
|
|||
|
|
@ -349,8 +349,8 @@
|
|||
#:missing-party [missing-party #f])
|
||||
(define num-values (length results))
|
||||
(define blame-case (if case-context
|
||||
(blame-add-context blame (format "the ~a case of"
|
||||
(n->th (+ case-context 1))))
|
||||
(blame-add-context blame
|
||||
(nth-case-of (+ case-context 1)))
|
||||
blame))
|
||||
(raise-blame-error (blame-add-range-context blame-case)
|
||||
#:missing-party missing-party
|
||||
|
|
@ -360,8 +360,7 @@
|
|||
num-values (if (= num-values 1) "" "s")))
|
||||
|
||||
(define (blame-add-nth-arg-context blame n)
|
||||
(blame-add-context blame
|
||||
(format "the ~a argument of" (n->th n))))
|
||||
(blame-add-context blame (nth-argument-of n)))
|
||||
|
||||
(define (raise-wrong-number-of-args-error
|
||||
blame #:missing-party [missing-party #f] val
|
||||
|
|
|
|||
|
|
@ -560,7 +560,7 @@
|
|||
[n (in-naturals 1)])
|
||||
((get/build-late-neg-projection dom)
|
||||
(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))))
|
||||
(define rest-blame
|
||||
(if (ellipsis-rest-arg-ctc? rest)
|
||||
|
|
|
|||
|
|
@ -39,24 +39,35 @@
|
|||
(quasisyntax/loc stx (#%expression #,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 ()
|
||||
[(_ c v pos neg name loc)
|
||||
(syntax/loc stx
|
||||
(apply-contract c v pos neg name loc #t))]
|
||||
[(_ c v pos neg)
|
||||
[(_ c v pos neg #:limit-context limit-context-expression)
|
||||
(with-syntax ([name (syntax-local-infer-name stx)])
|
||||
(syntax/loc stx
|
||||
(apply-contract c v pos neg 'name
|
||||
(build-source-location #f)
|
||||
#t)))]
|
||||
[(_ c v pos neg #:no-context)
|
||||
limit-context-expression)))]
|
||||
[(_ 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)])
|
||||
(syntax/loc stx
|
||||
(apply-contract c v pos neg 'name
|
||||
(build-source-location #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)])
|
||||
(check-source-location! 'contract loc)
|
||||
(define clnp (contract-late-neg-projection c))
|
||||
|
|
@ -75,7 +86,7 @@
|
|||
|
||||
(if clnp #f neg)
|
||||
#t
|
||||
#:track-context? track-context?))
|
||||
#:context-limit context-limit))
|
||||
(cond
|
||||
[clnp (with-contract-continuation-mark
|
||||
(cons blame neg)
|
||||
|
|
|
|||
|
|
@ -31,48 +31,92 @@
|
|||
(define invariant-assertion-party (string->uninterned-symbol "invariant-assertion"))
|
||||
|
||||
(define (blame=? a b equal?/recur)
|
||||
(and (equal?/recur (blame-positive a) (blame-positive b))
|
||||
(equal?/recur (blame-negative a) (blame-negative b))
|
||||
(equal?/recur (blame-original? a) (blame-original? b))
|
||||
(equal?/recur (blame-more-stuff a) (blame-more-stuff b))))
|
||||
(and (or (and (blame-no-swap? a) (blame-no-swap? b))
|
||||
(and (blame-yes-swap? a) (blame-yes-swap? b)))
|
||||
(equal?/recur (blame-context-frame a) (blame-context-frame b))
|
||||
(equal?/recur (blame-and-more a) (blame-and-more b))))
|
||||
|
||||
(define (combine-them . args)
|
||||
(let loop ([args args])
|
||||
(cond
|
||||
[(null? (cdr args)) (car args)]
|
||||
[else (bitwise-xor (car args) (* 3 (loop (cdr args))))])))
|
||||
(define (combine-them x y)
|
||||
(bitwise-xor x (* 3 y)))
|
||||
|
||||
(define (blame-hash b hash/recur)
|
||||
(combine-them (hash/recur (blame-positive b))
|
||||
(hash/recur (blame-negative b))
|
||||
(hash/recur (blame-original? b))
|
||||
(hash/recur (blame-more-stuff b))))
|
||||
(combine-them (hash/recur (blame-no-swap? b))
|
||||
(combine-them (hash/recur (blame-context-frame b))
|
||||
(hash/recur (blame-and-more b)))))
|
||||
|
||||
;; missing-party? field is #t 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)
|
||||
(define-struct more-stuff
|
||||
[source value build-name context top-known? important missing-party? extra-fields]
|
||||
(define-struct all-the-info
|
||||
[positive
|
||||
negative
|
||||
source value build-name top-known? important missing-party? context-limit extra-fields]
|
||||
#:transparent)
|
||||
|
||||
(define-struct blame
|
||||
(positive negative original? [swapped #:mutable] more-stuff)
|
||||
;; and-more : (or/c blame-no-swap? blame-swap? all-the-info?)
|
||||
;; context : string?
|
||||
(define-struct blame (context-frame and-more)
|
||||
#:property prop:equal+hash
|
||||
(list blame=? blame-hash blame-hash))
|
||||
|
||||
(define (blame-source b) (more-stuff-source (blame-more-stuff b)))
|
||||
(define (blame-value b) (more-stuff-value (blame-more-stuff b)))
|
||||
(define (blame-context b) (more-stuff-context (blame-more-stuff b)))
|
||||
(define (blame-top-known? b) (more-stuff-top-known? (blame-more-stuff b)))
|
||||
(define (blame-important b) (more-stuff-important (blame-more-stuff b)))
|
||||
(define (blame-missing-party? b) (more-stuff-missing-party? (blame-more-stuff b)))
|
||||
(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-struct (blame-no-swap blame) ()
|
||||
#:property prop:equal+hash
|
||||
(list blame=? blame-hash blame-hash))
|
||||
(define-struct (blame-yes-swap blame) ()
|
||||
#:property prop:equal+hash
|
||||
(list blame=? blame-hash blame-hash))
|
||||
|
||||
(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
|
||||
(let ([make-blame
|
||||
(λ (source value build-name positive negative original?
|
||||
#:track-context? [track-context? #t])
|
||||
#:context-limit [context-limit #f])
|
||||
(unless (srcloc? source)
|
||||
(raise-argument-error 'make-blame "srcloc?" 0
|
||||
source value build-name positive negative original?))
|
||||
|
|
@ -83,6 +127,11 @@
|
|||
(unless positive
|
||||
(raise-type-error 'make-blame "(not/c #f)" 3
|
||||
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
|
||||
(let* ([uniq (box #f)]
|
||||
[ans uniq])
|
||||
|
|
@ -90,46 +139,27 @@
|
|||
(when (eq? uniq ans)
|
||||
(set! ans (build-name)))
|
||||
ans)))
|
||||
(define more-stuff
|
||||
(make-more-stuff
|
||||
(define all-the-info
|
||||
(make-all-the-info
|
||||
(list positive)
|
||||
(and negative (list negative))
|
||||
source
|
||||
value
|
||||
build/memo-name
|
||||
(if track-context? '() #f)
|
||||
#t
|
||||
#f
|
||||
(not negative)
|
||||
context-limit
|
||||
'()))
|
||||
(new-blame (list positive)
|
||||
(and negative (list negative))
|
||||
original?
|
||||
more-stuff))])
|
||||
;; we always start with a yes-swap or no-swap struct
|
||||
;; so be careful in other parts of the code to ignore
|
||||
;; it, as appropriate.
|
||||
(if original?
|
||||
(blame-no-swap/intern #f all-the-info)
|
||||
(blame-yes-swap/intern #f all-the-info)))])
|
||||
make-blame))
|
||||
|
||||
(define (new-blame/more-stuff b more-stuff)
|
||||
(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 seen '())
|
||||
(define (blame-add-context b s #:important [name #f] #:swap? [swap? #f])
|
||||
(unless (blame? b)
|
||||
(raise-argument-error 'blame-add-context
|
||||
|
|
@ -147,55 +177,164 @@
|
|||
(define (blame-add-unknown-context b)
|
||||
(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 context-limit (blame-context-limit b))
|
||||
(cond
|
||||
[(and (not (blame-context b))
|
||||
[(and context-limit
|
||||
;; if we are not tracking context,
|
||||
;; we are not updating the name
|
||||
;; at the top of the messages either
|
||||
; (not name)
|
||||
(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
|
||||
(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-context (if (and s (blame-context b))
|
||||
(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
|
||||
;; in this case, we need to make a new blame record
|
||||
(struct-copy
|
||||
more-stuff (blame-more-stuff b)
|
||||
[important (if name (important name new-original?) (blame-important b))]
|
||||
[context new-context/maybe-unknown]
|
||||
[top-known? (string? s)]))]))
|
||||
all-the-info inner-b
|
||||
[important (if name
|
||||
(important name new-original?)
|
||||
(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)
|
||||
|
||||
(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)
|
||||
(new-blame (blame-positive b)
|
||||
(list new-neg)
|
||||
(blame-original? b)
|
||||
(blame-more-stuff b)))
|
||||
(update-the-info
|
||||
b
|
||||
(λ (an-all-the-info swap?)
|
||||
(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)
|
||||
(new-blame (list new-pos)
|
||||
(blame-negative b)
|
||||
(blame-original? b)
|
||||
(blame-more-stuff b)))
|
||||
(update-the-info
|
||||
b
|
||||
(λ (an-all-the-info swap?)
|
||||
(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)
|
||||
(ensure-blame-known 'blame-update b)
|
||||
(new-blame (cons extra-positive (blame-positive b))
|
||||
(cons extra-negative (blame-negative b))
|
||||
(blame-original? b)
|
||||
(blame-more-stuff b)))
|
||||
(update-the-info
|
||||
b
|
||||
(λ (an-all-the-info swap?)
|
||||
(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)
|
||||
(unless (and (blame-positive blame)
|
||||
|
|
@ -212,9 +351,6 @@
|
|||
(define (show-blame-positive b) (show-blame blame-positive 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]
|
||||
#:transparent)
|
||||
|
||||
|
|
@ -255,32 +391,21 @@
|
|||
blame)))
|
||||
|
||||
(define (blame-add-missing-party b missing-party)
|
||||
|
||||
(define (check-and-fail)
|
||||
(cond
|
||||
[(not missing-party) b]
|
||||
[else
|
||||
(unless (blame-missing-party? b)
|
||||
(error 'blame-add-missing-party "already have the party: ~s; trying to add ~s"
|
||||
(if (blame-swapped? b) (blame-positive b) (blame-negative b))
|
||||
missing-party)))
|
||||
(cond
|
||||
[(not missing-party) b]
|
||||
[(blame-swapped? b)
|
||||
(check-and-fail)
|
||||
(new-blame (or (blame-positive b)
|
||||
(list missing-party))
|
||||
(blame-negative b)
|
||||
(blame-original? b)
|
||||
missing-party))
|
||||
(update-the-info
|
||||
b
|
||||
(λ (an-all-the-info swap?)
|
||||
(struct-copy
|
||||
more-stuff (blame-more-stuff b)
|
||||
[missing-party? #f]))]
|
||||
[else
|
||||
(check-and-fail)
|
||||
(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]))]))
|
||||
all-the-info an-all-the-info
|
||||
[negative (or (all-the-info-negative an-all-the-info)
|
||||
(list missing-party))]
|
||||
[missing-party? #f])))]))
|
||||
|
||||
(define (blame-fmt->-string blame fmt)
|
||||
(cond
|
||||
|
|
@ -454,12 +579,13 @@
|
|||
(raise-argument-error 'blame-add-extra-field
|
||||
"string?"
|
||||
2 b name field))
|
||||
(new-blame/more-stuff
|
||||
(update-the-info
|
||||
b
|
||||
(λ (an-all-the-info swap?)
|
||||
(struct-copy
|
||||
more-stuff (blame-more-stuff b)
|
||||
all-the-info an-all-the-info
|
||||
[extra-fields (cons (format " ~a: ~a" name field)
|
||||
(blame-extra-fields b))])))
|
||||
(blame-extra-fields b))]))))
|
||||
|
||||
;; combine-lines : (-> (listof (or/c string? #f))) string?)
|
||||
;; combines each of 'lines' into a single message, dropping #fs,
|
||||
|
|
@ -505,11 +631,9 @@
|
|||
[(path? x) (path->relative-string/library x)]
|
||||
[else x]))
|
||||
|
||||
|
||||
(define (from-info x)
|
||||
(convert-blame-singleton (last x)))
|
||||
|
||||
|
||||
(define (convert-blame-party x)
|
||||
(let ((preface
|
||||
(cond [(< 1 (length x))
|
||||
|
|
|
|||
|
|
@ -217,7 +217,7 @@
|
|||
(blame-add-context
|
||||
(blame-add-context
|
||||
blame
|
||||
(format "the ~a case of" (n->th (+ (car f) 1))))
|
||||
(nth-case-of (+ (car f) 1)))
|
||||
"the domain of"
|
||||
#:swap? #t)))
|
||||
dom-ctcs+case-nums)
|
||||
|
|
|
|||
|
|
@ -83,6 +83,9 @@
|
|||
raise-predicate-blame-error-failure
|
||||
|
||||
n->th
|
||||
nth-argument-of
|
||||
nth-element-of
|
||||
nth-case-of
|
||||
|
||||
false/c-contract
|
||||
true/c-contract
|
||||
|
|
@ -918,6 +921,33 @@
|
|||
[(3) "rd"]
|
||||
[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
|
||||
(contract-pos/neg-doubling e1 e2)
|
||||
|
|
|
|||
|
|
@ -811,13 +811,7 @@
|
|||
(expected-a-list val blame #:missing-party neg-party)]))))
|
||||
|
||||
(define (add-list-context blame i)
|
||||
(blame-add-context blame (format "the ~a~a element of"
|
||||
i
|
||||
(case (modulo i 10)
|
||||
[(1) "st"]
|
||||
[(2) "nd"]
|
||||
[(3) "rd"]
|
||||
[else "th"]))))
|
||||
(blame-add-context blame (nth-element-of i)))
|
||||
|
||||
(struct chaperone-list/c generic-list/c ()
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
|
|
|
|||
|
|
@ -260,7 +260,7 @@
|
|||
(stx->srcloc-expr srcloc-id)
|
||||
'provide/contract
|
||||
pos-module-source
|
||||
#t)
|
||||
#f)
|
||||
#,@(if provide?
|
||||
(list #`(provide (rename-out [#,id-rename external-name])))
|
||||
null)))
|
||||
|
|
@ -281,7 +281,7 @@
|
|||
srcloc-expr
|
||||
contract-error-name
|
||||
pos-module-source
|
||||
track-context?)
|
||||
context-limit)
|
||||
(define-values (arrow? the-valid-app-shapes)
|
||||
(syntax-case ctrct (-> ->* ->i)
|
||||
[(-> . _)
|
||||
|
|
@ -309,7 +309,7 @@
|
|||
'#,name-for-blame
|
||||
#,pos-module-source
|
||||
#,srcloc-expr
|
||||
'#,track-context?))
|
||||
#,context-limit))
|
||||
#,@(if arrow?
|
||||
(list #`(define extra-neg-party-argument-fn
|
||||
(wrapped-extra-arg-arrow-extra-neg-party-argument
|
||||
|
|
@ -354,17 +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 track-context?)
|
||||
(define-values (pos-blame-party-expr srcloc-expr name-for-blame context-limit)
|
||||
(let loop ([kwd-args (syntax->list #'(kwd-args ...))]
|
||||
[pos-blame-party-expr #'(quote-module-path)]
|
||||
[srcloc-expr #f]
|
||||
[name-for-blame #f]
|
||||
[track-context? #t])
|
||||
[context-limit #f])
|
||||
(cond
|
||||
[(null? kwd-args) (values pos-blame-party-expr
|
||||
(or srcloc-expr (stx->srcloc-expr stx))
|
||||
(or name-for-blame #'new-id)
|
||||
track-context?)]
|
||||
context-limit)]
|
||||
[else
|
||||
(define kwd (car kwd-args))
|
||||
(cond
|
||||
|
|
@ -376,7 +376,7 @@
|
|||
(cadr kwd-args)
|
||||
srcloc-expr
|
||||
name-for-blame
|
||||
track-context?)]
|
||||
context-limit)]
|
||||
[(equal? (syntax-e kwd) '#:srcloc)
|
||||
(when (null? (cdr kwd-args))
|
||||
(raise-syntax-error #f "expected a keyword argument to follow #:srcloc"
|
||||
|
|
@ -385,7 +385,7 @@
|
|||
pos-blame-party-expr
|
||||
(cadr kwd-args)
|
||||
name-for-blame
|
||||
track-context?)]
|
||||
context-limit)]
|
||||
[(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"
|
||||
|
|
@ -399,19 +399,22 @@
|
|||
pos-blame-party-expr
|
||||
srcloc-expr
|
||||
name-for-blame
|
||||
track-context?)]
|
||||
[(equal? (syntax-e kwd) '#:no-context)
|
||||
(loop (cdr kwd-args)
|
||||
context-limit)]
|
||||
[(equal? (syntax-e kwd) '#:context-limit)
|
||||
(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
|
||||
srcloc-expr
|
||||
name-for-blame
|
||||
#f)]
|
||||
(cadr kwd-args))]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(string-append
|
||||
"expected one of the keywords"
|
||||
" #:pos-source, #:srcloc, #:name-for-blame, or #:no-context")
|
||||
" #:pos-source, #:srcloc, #:name-for-blame, or #:context-limit")
|
||||
stx
|
||||
(car kwd-args))])])))
|
||||
(internal-function-to-be-figured-out #'ctrct
|
||||
|
|
@ -422,10 +425,10 @@
|
|||
srcloc-expr
|
||||
'define-module-boundary-contract
|
||||
pos-blame-party-expr
|
||||
track-context?))])]))
|
||||
context-limit))])]))
|
||||
|
||||
;; ... -> (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])
|
||||
;; when we're building the val-first projection
|
||||
;; here we might be needing the plus1 arity
|
||||
|
|
@ -437,7 +440,7 @@
|
|||
(λ () (contract-name ctc))
|
||||
pos-module-source
|
||||
#f #t
|
||||
#:track-context? track-context?))
|
||||
#:context-limit context-limit))
|
||||
(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
|
||||
|
|
|
|||
|
|
@ -466,13 +466,12 @@
|
|||
([c (in-list elem-ctcs)]
|
||||
[i (in-naturals)])
|
||||
((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)
|
||||
([c (in-list elem-ctcs)]
|
||||
[i (in-naturals)])
|
||||
((get/build-late-neg-projection c)
|
||||
(blame-add-context blame (format "the ~a element of" (n->th i))
|
||||
#:swap? #t)))))
|
||||
(blame-add-context blame (nth-element-of i) #:swap? #t)))))
|
||||
(cond
|
||||
[filled?
|
||||
(λ (val neg-party)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user