add blame-replaced-negative?

This commit is contained in:
Robby Findler 2021-02-25 22:42:32 -06:00
parent 3d04b71ced
commit 288d13b85a
4 changed files with 46 additions and 10 deletions

View File

@ -2776,6 +2776,12 @@ the other; both are provided for convenience and clarity.
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?]{
Produces a @racket[blame?] object just like @racket[b] except
that it adds @racket[pos] and @racket[neg] to the positive

View File

@ -178,6 +178,36 @@
"4")
"5"))
'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
#:test-case-name "blame.rkt setup.1"

View File

@ -88,6 +88,7 @@
blame-swapped?
blame-swap
blame-replace-negative ;; used for indy blame
blame-replaced-negative?
blame-update ;; used for option contract transfers
blame-add-context
blame-add-unknown-context

View File

@ -12,10 +12,12 @@
blame-swapped?
blame-swap
blame-replace-negative ;; used for indy blame
blame-replaced-negative? ;; used for indy blame
blame-update ;; used for option contract transfers
blame-add-context
blame-add-unknown-context
blame-context
blame-replaced-negative?
blame-add-missing-party
blame-missing-party?
@ -55,7 +57,8 @@
(define-struct all-the-info
[positive
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)
;; 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-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-replaced-negative? b) (all-the-info-replaced-negative? (blame->all-the-info b)))
(define (blame-get-info b f)
(let loop ([b b]
@ -153,7 +157,8 @@
#f
(not negative)
context-limit
'()))
'()
#f))
;; 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.
@ -283,22 +288,16 @@
(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)
(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
[replaced-negative? #t]
[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
[replaced-negative? #t]
[negative (list new-neg)]))
(define (blame-update b extra-positive extra-negative)