adjust implementation of recursive contract to cope with
the fact that blame object equality now works right and
adding context to a blame object doesn't produce an equal?
blame object
also it appears that blame-add-unknown-context is not actually
being called so lets just get rid of that functionality
(but preserve reasonable backwards compatibility in
case someone is actually calling that function or
supplying #f to blame-add-context)
And the interning of blame objects was not intended to be
in 0b3f4b627e, so get rid of it here
closes racket/typed-racket#722
This commit is contained in:
Robby Findler
parent
4b2a202640
commit
be7fe82ea8
|
|
@ -2526,13 +2526,13 @@ The @racket[swap?] argument has the effect of calling @racket[blame-swap]
|
|||
while adding the layer of context, but without creating an extra
|
||||
@|blame-object|.
|
||||
|
||||
The context information recorded in blame structs keeps track of
|
||||
combinators that do not add information, and add the string @racket["..."]
|
||||
for them, so programmers at least see that there was some context
|
||||
they are missing in the error messages. Accordingly, since there are
|
||||
combinators that should not add any context (e.g., @racket[recursive-contract]),
|
||||
passing @racket[#f] as the context string argument avoids adding the
|
||||
@racket["..."] string.
|
||||
|
||||
Passing @racket[#f] as the context string argument is no longer relevant.
|
||||
For backwards compatibility, @racket[blame-add-context] returns @racket[b]
|
||||
when @racket[context] is @racket[#f].
|
||||
|
||||
@history[#:changed "6.90.0.29" @elem{The @racket[context] argument being
|
||||
@racket[#f] is no longer relevant.}]
|
||||
}
|
||||
|
||||
@defproc[(blame-context [blame blame?]) (listof string?)]{
|
||||
|
|
|
|||
|
|
@ -85,6 +85,15 @@
|
|||
'(letrec ([ctc (or/c number? (cons/c number? (recursive-contract ctc #:flat #:extra-delay)))])
|
||||
(contract ctc (cons 1 (cons 2 'not-a-number)) 'pos 'neg)))
|
||||
|
||||
(test/spec-passed/result
|
||||
'recursive-contract14
|
||||
'(let ()
|
||||
(define c (recursive-contract (or/c integer? (cons/c c integer?))))
|
||||
(void (contract (-> c any/c) void 'p 'n))
|
||||
((contract (-> c any/c) values 'p 'n) '(1 . 2)))
|
||||
'(1 . 2))
|
||||
|
||||
|
||||
(test/spec-passed/result
|
||||
'memoize-applied-blame
|
||||
'(let ()
|
||||
|
|
|
|||
|
|
@ -170,6 +170,7 @@
|
|||
#`(#,maker '#,stx
|
||||
(λ () #,arg)
|
||||
'#,(syntax-local-infer-name stx)
|
||||
'recursive-contract-val->lnp-not-yet-initialized
|
||||
#,(if list-contract? #'#t #'#f)
|
||||
#,@(if (equal? (syntax-e type) '#:flat)
|
||||
(list (if extra-delay? #'#t #'#f))
|
||||
|
|
@ -207,6 +208,7 @@
|
|||
(unless (list-contract? forced-ctc)
|
||||
(raise-argument-error 'recursive-contract "list-contract?" forced-ctc)))
|
||||
(set-recursive-contract-ctc! ctc forced-ctc)
|
||||
(set-recursive-contract-blame->val-np->val! ctc (make-blame->val-np->val ctc))
|
||||
(when (and (pair? old-name) (pair? (cdr old-name)))
|
||||
;; this guard will be #f when we are forcing this contract
|
||||
;; in a nested which (which can make the `cddr` below fail)
|
||||
|
|
@ -217,33 +219,48 @@
|
|||
forced-ctc]
|
||||
[else current]))
|
||||
|
||||
(define (make-blame->val-np->val ctc)
|
||||
(define list-check? (recursive-contract-list-contract? ctc))
|
||||
(define blame-accepting-func-cell (make-thread-cell #f))
|
||||
(define (do-list-check val neg-party blame-known)
|
||||
(when list-check?
|
||||
(unless (list? val)
|
||||
(raise-blame-error blame-known #:missing-party neg-party
|
||||
val
|
||||
'(expected: "list?" given: "~e")
|
||||
val))))
|
||||
(λ (blame)
|
||||
(cond
|
||||
[(thread-cell-ref blame-accepting-func-cell)
|
||||
=>
|
||||
(λ (blame-accepting-func) (blame-accepting-func blame))]
|
||||
[else
|
||||
(define r-ctc (force-recursive-contract ctc))
|
||||
(define f (get/build-late-neg-projection r-ctc))
|
||||
(define val-neg-party-acceptor (make-thread-cell #f))
|
||||
(λ (val neg-party)
|
||||
(cond
|
||||
[(thread-cell-ref val-neg-party-acceptor)
|
||||
=>
|
||||
(λ (f) (f val neg-party))]
|
||||
[else
|
||||
(thread-cell-set! blame-accepting-func-cell
|
||||
(λ (blame)
|
||||
(λ (val neg-party)
|
||||
((thread-cell-ref val-neg-party-acceptor) val neg-party))))
|
||||
(do-list-check val neg-party blame)
|
||||
(define f-of-blame 'f-of-blame-not-yet-set)
|
||||
(thread-cell-set! val-neg-party-acceptor
|
||||
(λ (val neg-party)
|
||||
(do-list-check val neg-party blame)
|
||||
(f-of-blame val neg-party)))
|
||||
(set! f-of-blame (f blame))
|
||||
(f-of-blame val neg-party)]))])))
|
||||
|
||||
(define (recursive-contract-late-neg-projection ctc)
|
||||
(cond
|
||||
[(recursive-contract-list-contract? ctc)
|
||||
(λ (blame)
|
||||
(define r-ctc (force-recursive-contract ctc))
|
||||
(define f (get/build-late-neg-projection r-ctc))
|
||||
(define blame-known (blame-add-context blame #f))
|
||||
(define f-blame-known (make-thread-cell #f))
|
||||
(λ (val neg-party)
|
||||
(unless (list? val)
|
||||
(raise-blame-error blame-known #:missing-party neg-party
|
||||
val
|
||||
'(expected: "list?" given: "~e")
|
||||
val))
|
||||
(unless (thread-cell-ref f-blame-known)
|
||||
(thread-cell-set! f-blame-known (f blame-known)))
|
||||
((thread-cell-ref f-blame-known) val neg-party)))]
|
||||
[else
|
||||
(λ (blame)
|
||||
(define r-ctc (force-recursive-contract ctc))
|
||||
(define f (get/build-late-neg-projection r-ctc))
|
||||
(define blame-known (blame-add-context blame #f))
|
||||
(define f-blame-known (make-thread-cell #f))
|
||||
(λ (val neg-party)
|
||||
(unless (thread-cell-ref f-blame-known)
|
||||
(thread-cell-set! f-blame-known (f blame-known)))
|
||||
((thread-cell-ref f-blame-known) val neg-party)))]))
|
||||
(λ (blame)
|
||||
(force-recursive-contract ctc)
|
||||
((recursive-contract-blame->val-np->val ctc) blame)))
|
||||
|
||||
(define (flat-recursive-contract-late-neg-projection ctc)
|
||||
(cond
|
||||
|
|
@ -287,7 +304,11 @@
|
|||
(force-recursive-contract ctc)
|
||||
(contract-random-generate/choose (recursive-contract-ctc ctc) (- fuel 1))])))
|
||||
|
||||
(struct recursive-contract ([name #:mutable] [thunk #:mutable] [ctc #:mutable] list-contract?)
|
||||
(struct recursive-contract ([name #:mutable]
|
||||
thunk
|
||||
[ctc #:mutable]
|
||||
[blame->val-np->val #:mutable]
|
||||
list-contract?)
|
||||
#:property prop:recursive-contract (λ (this)
|
||||
(force-recursive-contract this)
|
||||
(recursive-contract-ctc this)))
|
||||
|
|
|
|||
|
|
@ -39,32 +39,37 @@
|
|||
(define (combine-them x y)
|
||||
(bitwise-xor x (* 3 y)))
|
||||
|
||||
(define (blame-hash b hash/recur)
|
||||
(define (blame-hash/combine b hash/recur combine-them)
|
||||
(combine-them (hash/recur (blame-no-swap? b))
|
||||
(combine-them (hash/recur (blame-context-frame b))
|
||||
(hash/recur (blame-and-more b)))))
|
||||
|
||||
(define (blame-hash b hash/recur)
|
||||
(blame-hash/combine b hash/recur (λ (x y) (bitwise-xor x (* 3 y)))))
|
||||
(define (blame-secondary-hash b hash/recur)
|
||||
(blame-hash/combine b hash/recur (λ (x y) (bitwise-xor (* 5 x) y))))
|
||||
|
||||
;; 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 all-the-info
|
||||
[positive
|
||||
negative
|
||||
source value build-name top-known? important missing-party? context-limit extra-fields]
|
||||
source value build-name important missing-party? context-limit extra-fields]
|
||||
#:transparent)
|
||||
|
||||
;; 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))
|
||||
(list blame=? blame-hash blame-secondary-hash))
|
||||
|
||||
(define-struct (blame-no-swap blame) ()
|
||||
#:property prop:equal+hash
|
||||
(list blame=? blame-hash blame-hash))
|
||||
(list blame=? blame-hash blame-secondary-hash))
|
||||
(define-struct (blame-yes-swap blame) ()
|
||||
#:property prop:equal+hash
|
||||
(list blame=? blame-hash blame-hash))
|
||||
(list blame=? blame-hash blame-secondary-hash))
|
||||
|
||||
(define (blame->all-the-info b)
|
||||
(let loop ([b b])
|
||||
|
|
@ -73,7 +78,6 @@
|
|||
[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))))
|
||||
|
|
@ -146,7 +150,6 @@
|
|||
source
|
||||
value
|
||||
build/memo-name
|
||||
#t
|
||||
#f
|
||||
(not negative)
|
||||
context-limit
|
||||
|
|
@ -155,11 +158,10 @@
|
|||
;; 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)))])
|
||||
(blame-no-swap #f all-the-info)
|
||||
(blame-yes-swap #f all-the-info)))])
|
||||
make-blame))
|
||||
|
||||
(define seen '())
|
||||
(define (blame-add-context b s #:important [name #f] #:swap? [swap? #f])
|
||||
(unless (blame? b)
|
||||
(raise-argument-error 'blame-add-context
|
||||
|
|
@ -172,20 +174,15 @@
|
|||
(format "~s" '(or/c string? #f))
|
||||
1
|
||||
b s))
|
||||
(do-blame-add-context b s name swap?))
|
||||
(cond
|
||||
[(string? s)
|
||||
(do-blame-add-context b s name swap?)]
|
||||
[else b]))
|
||||
|
||||
(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))
|
||||
;; this has become a no op. it seems to never have been
|
||||
;; documented. probably exported because of the Great
|
||||
;; Extra Export ScrewUp that happened years back
|
||||
(define (blame-add-unknown-context b) b)
|
||||
|
||||
(define (do-blame-add-context b s name swap?)
|
||||
(define context-limit (blame-context-limit b))
|
||||
|
|
@ -194,52 +191,45 @@
|
|||
;; 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))
|
||||
;(not name)
|
||||
)
|
||||
(cond
|
||||
[(and s (not (zero? context-limit)))
|
||||
[(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))]
|
||||
(blame-no-swap s limited-b)
|
||||
(blame-yes-swap 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)))]
|
||||
(blame-no-swap (blame-context-frame b) (blame-and-more b))
|
||||
(blame-yes-swap (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 blame-yes/no-swap (if swap? blame-yes-swap blame-no-swap))
|
||||
(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)))
|
||||
;; in this case, we need to make a new blame record
|
||||
(struct-copy
|
||||
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)])]))))
|
||||
(cond
|
||||
[name
|
||||
(let loop ([inner-b b])
|
||||
(cond
|
||||
[(blame-yes-swap? inner-b)
|
||||
(blame-yes-swap (blame-context-frame inner-b) (loop (blame-and-more inner-b)))]
|
||||
[(blame-no-swap? inner-b)
|
||||
(blame-no-swap (blame-context-frame inner-b) (loop (blame-and-more inner-b)))]
|
||||
[else
|
||||
(define new-original? (if swap? (not (blame-original? b)) (blame-original? b)))
|
||||
;; in this case, we need to make a new blame record
|
||||
(struct-copy
|
||||
all-the-info inner-b
|
||||
[important (if name
|
||||
(important name new-original?)
|
||||
(all-the-info-important inner-b))])]))]
|
||||
[else b]))
|
||||
(if swap?
|
||||
(blame-yes-swap/intern s inside-part)
|
||||
(blame-no-swap/intern s inside-part))]))
|
||||
(blame-yes-swap s inside-part)
|
||||
(blame-no-swap s inside-part))]))
|
||||
|
||||
(define (drop-to-limit b context-limit)
|
||||
(define short-enough?
|
||||
|
|
@ -269,10 +259,10 @@
|
|||
(set! swapped? swap?)
|
||||
b]))]
|
||||
[(blame-no-swap? b)
|
||||
(blame-no-swap/intern (blame-context-frame b)
|
||||
(blame-no-swap (blame-context-frame b)
|
||||
(loop (blame-and-more b) (- n 1)))]
|
||||
[(blame-yes-swap? b)
|
||||
(blame-yes-swap/intern (blame-context-frame b)
|
||||
(blame-yes-swap (blame-context-frame b)
|
||||
(loop (blame-and-more b) (- n 1)))])))
|
||||
(values limited-b swapped?)]))
|
||||
|
||||
|
|
@ -281,9 +271,9 @@
|
|||
(define (blame-swap b)
|
||||
(cond
|
||||
[(blame-yes-swap? b)
|
||||
(blame-no-swap/intern (blame-context-frame b) (blame-and-more b))]
|
||||
(blame-no-swap (blame-context-frame b) (blame-and-more b))]
|
||||
[(blame-no-swap? b)
|
||||
(blame-yes-swap/intern (blame-context-frame b) (blame-and-more b))]))
|
||||
(blame-yes-swap (blame-context-frame b) (blame-and-more b))]))
|
||||
|
||||
(define (blame-replace-negative b new-neg)
|
||||
(update-the-info
|
||||
|
|
@ -331,9 +321,9 @@
|
|||
[swap? #f])
|
||||
(cond
|
||||
[(blame-yes-swap? b)
|
||||
(blame-yes-swap/intern (blame-context-frame b) (loop (blame-and-more b) (not swap?)))]
|
||||
(blame-yes-swap (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?))]
|
||||
(blame-no-swap (blame-context-frame b) (loop (blame-and-more b) swap?))]
|
||||
[else (f b swap?)])))
|
||||
|
||||
(define (ensure-blame-known who blame)
|
||||
|
|
|
|||
|
|
@ -364,12 +364,6 @@
|
|||
'anonymous-flat-contract 'build-flat-contract-property #t #t)
|
||||
'build-flat-contract-property))
|
||||
|
||||
(define (blame-context-projection-wrapper proj)
|
||||
(λ (ctc)
|
||||
(define c-proj (proj ctc))
|
||||
(λ (blame)
|
||||
(c-proj (blame-add-unknown-context blame)))))
|
||||
|
||||
(define build-chaperone-contract-property
|
||||
(procedure-rename
|
||||
(build-property (compose make-chaperone-contract-property make-contract-property)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user