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.
|
||||
}
|
||||
|
||||
@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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
Loading…
Reference in New Issue
Block a user