From 288d13b85aa1677720148a348b1f93fdf5e90d15 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Thu, 25 Feb 2021 22:42:32 -0600
Subject: [PATCH] add blame-replaced-negative?

---
 .../scribblings/reference/contracts.scrbl     |  6 ++++
 .../tests/racket/contract/blame.rkt           | 30 +++++++++++++++++++
 .../collects/racket/contract/combinator.rkt   |  1 +
 .../racket/contract/private/blame.rkt         | 19 ++++++------
 4 files changed, 46 insertions(+), 10 deletions(-)

diff --git a/pkgs/racket-doc/scribblings/reference/contracts.scrbl b/pkgs/racket-doc/scribblings/reference/contracts.scrbl
index d681184e91..0edacb0257 100644
--- a/pkgs/racket-doc/scribblings/reference/contracts.scrbl
+++ b/pkgs/racket-doc/scribblings/reference/contracts.scrbl
@@ -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
diff --git a/pkgs/racket-test/tests/racket/contract/blame.rkt b/pkgs/racket-test/tests/racket/contract/blame.rkt
index 0e3ea3385f..05d7096992 100644
--- a/pkgs/racket-test/tests/racket/contract/blame.rkt
+++ b/pkgs/racket-test/tests/racket/contract/blame.rkt
@@ -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"
diff --git a/racket/collects/racket/contract/combinator.rkt b/racket/collects/racket/contract/combinator.rkt
index 367dfb038b..b9f641da06 100644
--- a/racket/collects/racket/contract/combinator.rkt
+++ b/racket/collects/racket/contract/combinator.rkt
@@ -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
diff --git a/racket/collects/racket/contract/private/blame.rkt b/racket/collects/racket/contract/private/blame.rkt
index 6d5b8bc6dd..1cbd2e8e99 100644
--- a/racket/collects/racket/contract/private/blame.rkt
+++ b/racket/collects/racket/contract/private/blame.rkt
@@ -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)