add blame-replaced-negative?
This commit is contained in:
parent
3d04b71ced
commit
288d13b85a
|
@ -2776,6 +2776,12 @@ the other; both are provided for convenience and clarity.
|
||||||
position @racket[b] has.
|
position @racket[b] has.
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@defproc[(blame-replaced-negative? [b blame?]) boolean?]{
|
||||||
|
Returns @racket[#t] if @racket[b] is the result of calling
|
||||||
|
@racket[blame-replace-negative] (or the result of some other function
|
||||||
|
whose input was the result of @racket[blame-replace-negative]).
|
||||||
|
}
|
||||||
|
|
||||||
@defproc[(blame-update [b blame?] [pos any/c] [neg any/c]) blame?]{
|
@defproc[(blame-update [b blame?] [pos any/c] [neg any/c]) blame?]{
|
||||||
Produces a @racket[blame?] object just like @racket[b] except
|
Produces a @racket[blame?] object just like @racket[b] except
|
||||||
that it adds @racket[pos] and @racket[neg] to the positive
|
that it adds @racket[pos] and @racket[neg] to the positive
|
||||||
|
|
|
@ -178,6 +178,36 @@
|
||||||
"4")
|
"4")
|
||||||
"5"))
|
"5"))
|
||||||
'neg)
|
'neg)
|
||||||
|
(test/spec-passed/result
|
||||||
|
'blame-selector.19
|
||||||
|
'(blame-replaced-negative?
|
||||||
|
(blame-replace-negative
|
||||||
|
(make-blame (srcloc "src.rkt" #f #f #f #f)
|
||||||
|
'whatever (λ () 'the-name) 'pos 'neg #t)
|
||||||
|
'neg2))
|
||||||
|
#t)
|
||||||
|
(test/spec-passed/result
|
||||||
|
'blame-selector.20
|
||||||
|
'(blame-replaced-negative?
|
||||||
|
(make-blame (srcloc "src.rkt" #f #f #f #f)
|
||||||
|
'whatever (λ () 'the-name) 'pos 'neg #t))
|
||||||
|
#f)
|
||||||
|
(test/spec-passed/result
|
||||||
|
'blame-selector.21
|
||||||
|
'(blame-replaced-negative?
|
||||||
|
(blame-swap
|
||||||
|
(blame-replace-negative
|
||||||
|
(make-blame (srcloc "src.rkt" #f #f #f #f)
|
||||||
|
'whatever (λ () 'the-name) 'pos 'neg #t)
|
||||||
|
'neg2)))
|
||||||
|
#t)
|
||||||
|
(test/spec-passed/result
|
||||||
|
'blame-selector.22
|
||||||
|
'(blame-replaced-negative?
|
||||||
|
(blame-swap
|
||||||
|
(make-blame (srcloc "src.rkt" #f #f #f #f)
|
||||||
|
'whatever (λ () 'the-name) 'pos 'neg #t)))
|
||||||
|
#f)
|
||||||
|
|
||||||
(contract-eval
|
(contract-eval
|
||||||
#:test-case-name "blame.rkt setup.1"
|
#:test-case-name "blame.rkt setup.1"
|
||||||
|
|
|
@ -88,6 +88,7 @@
|
||||||
blame-swapped?
|
blame-swapped?
|
||||||
blame-swap
|
blame-swap
|
||||||
blame-replace-negative ;; used for indy blame
|
blame-replace-negative ;; used for indy blame
|
||||||
|
blame-replaced-negative?
|
||||||
blame-update ;; used for option contract transfers
|
blame-update ;; used for option contract transfers
|
||||||
blame-add-context
|
blame-add-context
|
||||||
blame-add-unknown-context
|
blame-add-unknown-context
|
||||||
|
|
|
@ -12,10 +12,12 @@
|
||||||
blame-swapped?
|
blame-swapped?
|
||||||
blame-swap
|
blame-swap
|
||||||
blame-replace-negative ;; used for indy blame
|
blame-replace-negative ;; used for indy blame
|
||||||
|
blame-replaced-negative? ;; used for indy blame
|
||||||
blame-update ;; used for option contract transfers
|
blame-update ;; used for option contract transfers
|
||||||
blame-add-context
|
blame-add-context
|
||||||
blame-add-unknown-context
|
blame-add-unknown-context
|
||||||
blame-context
|
blame-context
|
||||||
|
blame-replaced-negative?
|
||||||
|
|
||||||
blame-add-missing-party
|
blame-add-missing-party
|
||||||
blame-missing-party?
|
blame-missing-party?
|
||||||
|
@ -55,7 +57,8 @@
|
||||||
(define-struct all-the-info
|
(define-struct all-the-info
|
||||||
[positive
|
[positive
|
||||||
negative
|
negative
|
||||||
source value build-name important missing-party? context-limit extra-fields]
|
source value build-name important missing-party? context-limit extra-fields
|
||||||
|
replaced-negative?]
|
||||||
#:transparent)
|
#:transparent)
|
||||||
|
|
||||||
;; and-more : (or/c blame-no-swap? blame-swap? all-the-info?)
|
;; and-more : (or/c blame-no-swap? blame-swap? all-the-info?)
|
||||||
|
@ -83,6 +86,7 @@
|
||||||
(define (blame-contract b) ((all-the-info-build-name (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-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-context-limit b) (all-the-info-context-limit (blame->all-the-info b)))
|
||||||
|
(define (blame-replaced-negative? b) (all-the-info-replaced-negative? (blame->all-the-info b)))
|
||||||
|
|
||||||
(define (blame-get-info b f)
|
(define (blame-get-info b f)
|
||||||
(let loop ([b b]
|
(let loop ([b b]
|
||||||
|
@ -153,7 +157,8 @@
|
||||||
#f
|
#f
|
||||||
(not negative)
|
(not negative)
|
||||||
context-limit
|
context-limit
|
||||||
'()))
|
'()
|
||||||
|
#f))
|
||||||
;; we always start with a yes-swap or no-swap struct
|
;; we always start with a yes-swap or no-swap struct
|
||||||
;; so be careful in other parts of the code to ignore
|
;; so be careful in other parts of the code to ignore
|
||||||
;; it, as appropriate.
|
;; it, as appropriate.
|
||||||
|
@ -283,22 +288,16 @@
|
||||||
(all-the-info-replace-positive an-all-the-info new-neg)
|
(all-the-info-replace-positive an-all-the-info new-neg)
|
||||||
(all-the-info-replace-negative an-all-the-info new-neg)))))
|
(all-the-info-replace-negative an-all-the-info new-neg)))))
|
||||||
|
|
||||||
(define (blame-replace-positive b new-pos)
|
|
||||||
(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)
|
(define (all-the-info-replace-positive an-all-the-info new-pos)
|
||||||
(struct-copy
|
(struct-copy
|
||||||
all-the-info an-all-the-info
|
all-the-info an-all-the-info
|
||||||
|
[replaced-negative? #t]
|
||||||
[positive (list new-pos)]))
|
[positive (list new-pos)]))
|
||||||
|
|
||||||
(define (all-the-info-replace-negative an-all-the-info new-neg)
|
(define (all-the-info-replace-negative an-all-the-info new-neg)
|
||||||
(struct-copy
|
(struct-copy
|
||||||
all-the-info an-all-the-info
|
all-the-info an-all-the-info
|
||||||
|
[replaced-negative? #t]
|
||||||
[negative (list new-neg)]))
|
[negative (list new-neg)]))
|
||||||
|
|
||||||
(define (blame-update b extra-positive extra-negative)
|
(define (blame-update b extra-positive extra-negative)
|
||||||
|
|
Loading…
Reference in New Issue
Block a user