From 4aabe505be4aad4309a89619f633fc66ac109dd8 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 10 Dec 2015 18:35:50 -0600 Subject: [PATCH] fix missing party and indy blame interaction (also add all of the fields to the equal and hashing functions) --- .../tests/racket/contract/blame.rkt | 131 +++++++++++++++++- .../racket/contract/private/blame.rkt | 43 ++++-- 2 files changed, 157 insertions(+), 17 deletions(-) diff --git a/pkgs/racket-test/tests/racket/contract/blame.rkt b/pkgs/racket-test/tests/racket/contract/blame.rkt index 5840354c41..61f70d0469 100644 --- a/pkgs/racket-test/tests/racket/contract/blame.rkt +++ b/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))))) + + ) diff --git a/racket/collects/racket/contract/private/blame.rkt b/racket/collects/racket/contract/private/blame.rkt index 700576e1c4..4779984e22 100644 --- a/racket/collects/racket/contract/private/blame.rkt +++ b/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