fix missing party and indy blame interaction

(also add all of the fields to the equal and hashing
functions)

pkgs/racket-test/tests/racket/contract/blame.rkt

@@ -2,8 +2,131 @@
 (require "test-util.rkt")
 
 (parameterize ([current-contract-namespace
-                (make-basic-contract-namespace 'racket/contract)])
-  
+                (make-basic-contract-namespace 'racket/contract
+                                               'racket/contract/private/blame)])
+
+  (test/spec-passed/result
+   'blame-selector.1
+   '(blame-positive (make-blame (srcloc "src.rkt" #f #f #f #f)
+                                'whatever (λ () 'the-name) 'pos 'neg #t))
+   'pos)
+  (test/spec-passed/result
+   'blame-selector.2
+   '(blame-negative (make-blame (srcloc "src.rkt" #f #f #f #f)
+                                'whatever (λ () 'the-name) 'pos 'neg #t))
+   'neg)
+  (test/spec-passed/result
+   'blame-selector.3
+   '(blame-positive
+     (blame-swap
+      (make-blame (srcloc "src.rkt" #f #f #f #f)
+                  'whatever (λ () 'the-name) 'pos 'neg #t)))
+   'neg)
+  (test/spec-passed/result
+   'blame-selector.4
+   '(blame-original?
+     (make-blame (srcloc "src.rkt" #f #f #f #f)
+                 'whatever (λ () 'the-name) 'pos 'neg #t))
+   #t)
+  (test/spec-passed/result
+   'blame-selector.5
+   '(blame-original?
+     (blame-swap
+      (make-blame (srcloc "src.rkt" #f #f #f #f)
+                  'whatever (λ () 'the-name) 'pos 'neg #t)))
+   #f)
+  (test/spec-passed/result
+   'blame-selector.6
+   '(blame-negative
+     (blame-replace-negative
+      (make-blame (srcloc "src.rkt" #f #f #f #f)
+                  'whatever (λ () 'the-name) 'pos 'neg #t)
+      'neg2))
+   'neg2)
+  (test/spec-passed/result
+   'blame-selector.7
+   '(blame-positive
+     (blame-swap
+      (blame-replace-negative
+       (make-blame (srcloc "src.rkt" #f #f #f #f)
+                   'whatever (λ () 'the-name) 'pos 'neg #t)
+       'neg2)))
+   'neg2)
+  (test/spec-passed/result
+   'blame-selector.8
+   '(blame-positive
+     (make-blame (srcloc "src.rkt" #f #f #f #f)
+                 'whatever (λ () 'the-name) 'pos #f #t))
+   'pos)
+  (test/spec-passed/result
+   'blame-selector.9
+   '(blame-positive
+     (blame-add-missing-party
+      (make-blame (srcloc "src.rkt" #f #f #f #f)
+                  'whatever (λ () 'the-name) 'pos #f #t)
+      'neg))
+   'pos)
+  (test/spec-passed/result
+   'blame-selector.10
+   '(blame-negative
+     (blame-add-missing-party
+      (make-blame (srcloc "src.rkt" #f #f #f #f)
+                  'whatever (λ () 'the-name) 'pos #f #t)
+      'neg))
+   'neg)
+  (test/spec-passed/result
+   'blame-selector.11
+   '(blame-negative
+     (blame-add-missing-party
+      (blame-swap
+       (make-blame (srcloc "src.rkt" #f #f #f #f)
+                   'whatever (λ () 'the-name) 'pos #f #t))
+      'pos))
+   'pos)
+  (test/spec-passed/result
+   'blame-selector.12
+   '(blame-positive
+     (blame-add-missing-party
+      (blame-swap
+       (make-blame (srcloc "src.rkt" #f #f #f #f)
+                   'whatever (λ () 'the-name) 'pos #f #t))
+      'neg))
+   'neg)
+  (test/spec-passed/result
+   'blame-selector.13
+   '(blame-negative
+     (blame-add-missing-party
+      (blame-replace-negative
+       (make-blame (srcloc "src.rkt" #f #f #f #f)
+                   'whatever (λ () 'the-name) 'pos #f #t)
+       'neg2)
+      'neg))
+   'neg2)
+  (test/spec-passed/result
+   'blame-selector.14
+   '(blame-positive
+     (blame-add-missing-party
+      (blame-swap
+       (blame-replace-negative
+        (make-blame (srcloc "src.rkt" #f #f #f #f)
+                    'whatever (λ () 'the-name) 'pos #f #t)
+        'neg2))
+      'neg))
+   'neg2)
+  (test/spec-passed/result
+   'blame-selector.15
+   '(with-handlers ([exn:fail?
+                     (λ (x) (regexp-match? #rx"^blame-add-missing-party:"
+                                           (exn-message x)))])
+      (blame-add-missing-party
+       (blame-add-missing-party
+        (make-blame (srcloc "src.rkt" #f #f #f #f)
+                    'whatever (λ () 'the-name) 'pos #f #t)
+        'neg)
+       'neg2)
+      'no-exn-raised)
+   #t)
+
   (contract-eval
    #:test-case-name "blame.rkt setup.1"
    '(module blame-ok/c racket/base
@@ -158,4 +281,6 @@
     (test/no-error
      '(let ()
         (define-struct/contract thing ([stuff flat-blame-ok/c]))
-        (thing-stuff (thing 5))))))
+        (thing-stuff (thing 5)))))
+
+  )

racket/collects/racket/contract/private/blame.rkt

@@ -30,7 +30,11 @@
        (equal?/recur (blame-contract a) (blame-contract b))
        (equal?/recur (blame-positive a) (blame-positive b))
        (equal?/recur (blame-negative a) (blame-negative b))
-       (equal?/recur (blame-original? a) (blame-original? b))))
+       (equal?/recur (blame-original? a) (blame-original? b))
+       (equal?/recur (blame-context a) (blame-context b))
+       (equal?/recur (blame-top-known? a) (blame-top-known? b))
+       (equal?/recur (blame-important a) (blame-important b))
+       (equal?/recur (blame-missing-party? a) (blame-missing-party? b))))
 
 (define (blame-hash b hash/recur)
   (bitwise-xor (hash/recur (blame-source b))
@@ -38,10 +42,17 @@
                (hash/recur (blame-contract b))
                (hash/recur (blame-positive b))
                (hash/recur (blame-negative b))
-               (hash/recur (blame-original? b))))
+               (hash/recur (blame-original? b))
+               (hash/recur (blame-context b))
+               (hash/recur (blame-top-known? b))
+               (hash/recur (blame-important b))
+               (hash/recur (blame-missing-party? b))))
 
+;; 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 blame
-  [source value build-name positive negative original? context top-known? important]
+  [source value build-name positive negative original? context top-known? important missing-party?]
   #:property prop:equal+hash
   (list blame=? blame-hash blame-hash))
 
@@ -67,7 +78,8 @@
             original?
             '()
             #t 
-            #f))])
+            #f
+            (not negative)))])
     make-blame))
 
 ;; s : (or/c string? #f)
@@ -177,22 +189,25 @@
     blame)))
 
 (define (blame-add-missing-party b missing-party)
+  (define (check-and-fail)
+    (unless (blame-missing-party? b)
+      (error 'blame-add-missing-party "already have the party: ~s; trying to add ~s" 
+             (if (blame-swapped? b) (blame-positive b) (blame-negative b))
+             missing-party)))
   (cond
     [(not missing-party) b]
     [(blame-swapped? b)
-     (when (blame-positive b)
-       (error 'add-missing-party "already have the party: ~s; trying to add ~s" 
-              (blame-positive b)
-              missing-party))
+     (check-and-fail)
      (struct-copy blame b
-                  [positive (list missing-party)])]
+                  [positive (or (blame-positive b)
+                                (list missing-party))]
+                  [missing-party? #f])]
     [else
-     (when (blame-negative b)
-       (error 'add-missing-party "already have the party: ~s; trying to add ~s" 
-              (blame-negative b)
-              missing-party))
+     (check-and-fail)
      (struct-copy blame b
-                  [negative (list missing-party)])]))
+                  [negative (or (blame-negative b)
+                                (list missing-party))]
+                  [missing-party? #f])]))
 
 (define (blame-fmt->-string blame fmt)
   (cond