diff --git a/pkgs/racket-test/tests/racket/contract/assertion.rkt b/pkgs/racket-test/tests/racket/contract/assertion.rkt index 88c11e053e..ff6b67e7ec 100644 --- a/pkgs/racket-test/tests/racket/contract/assertion.rkt +++ b/pkgs/racket-test/tests/racket/contract/assertion.rkt @@ -16,7 +16,7 @@ (eval '(require 'contract-test-suite1))) (λ (x) (and (exn:fail:contract:blame? x) - (regexp-match #rx"contract from: contract-test-suite1" (exn-message x))))) + (regexp-match #rx"at: contract-test-suite1" (exn-message x))))) (contract-error-test 'assertion2 @@ -27,7 +27,7 @@ (eval '(require 'contract-test-suite2))) (λ (x) (and (exn:fail:contract:blame? x) - (regexp-match #rx"blaming: contract-test-suite2" (exn-message x))))) + (regexp-match #rx"^[^\n]*assertion violation\n" (exn-message x))))) (contract-error-test 'assertion3 @@ -38,4 +38,4 @@ (eval '(require 'contract-test-suite3))) (λ (x) (and (exn:fail:contract:blame? x) - (regexp-match #rx"blaming: contract-test-suite3" (exn-message x)))))) + (not (regexp-match #rx"blaming" (exn-message x))))))) diff --git a/pkgs/racket-test/tests/racket/contract/prof.rkt b/pkgs/racket-test/tests/racket/contract/prof.rkt index 31d048d5af..af6d24dbe6 100644 --- a/pkgs/racket-test/tests/racket/contract/prof.rkt +++ b/pkgs/racket-test/tests/racket/contract/prof.rkt @@ -263,9 +263,13 @@ (test/spec-passed/result 'contract-marks29 '(let () - (eval '(define f (invariant-assertion (-> (λ _ (named-blame? 'top-level)) - (λ _ (named-blame? 'top-level))) - (λ (x) 3)))) + (eval '(define f + (let ([nb + (λ _ (named-blame? + (dynamic-require 'racket/contract/private/blame + 'invariant-assertion-party)))]) + (invariant-assertion (-> nb nb) + (λ (x) 3))))) (eval '(f 2))) 3) diff --git a/racket/collects/racket/contract/private/base.rkt b/racket/collects/racket/contract/private/base.rkt index c43a73963b..b88f48bc75 100644 --- a/racket/collects/racket/contract/private/base.rkt +++ b/racket/collects/racket/contract/private/base.rkt @@ -85,11 +85,10 @@ (syntax-case stx () [(_ ctc e) (quasisyntax/loc stx - (let ([me (quote-module-name)]) - (contract ctc e - me me - '#,(syntax-local-infer-name stx) - '#,(build-source-location-vector #'ctc))))])) + (contract ctc e + invariant-assertion-party invariant-assertion-party + '#,(syntax-local-infer-name stx) + '#,(build-source-location-vector #'ctc)))])) (define-syntax (-recursive-contract stx) (define (parse-type/kwds arg type kwds) diff --git a/racket/collects/racket/contract/private/blame.rkt b/racket/collects/racket/contract/private/blame.rkt index f2d27f8064..e345249bae 100644 --- a/racket/collects/racket/contract/private/blame.rkt +++ b/racket/collects/racket/contract/private/blame.rkt @@ -24,7 +24,11 @@ raise-blame-error current-blame-format (struct-out exn:fail:contract:blame) - blame-fmt->-string) + blame-fmt->-string + + invariant-assertion-party) + +(define invariant-assertion-party (string->uninterned-symbol "invariant-assertion")) (define (blame=? a b equal?/recur) (and (equal?/recur (blame-source a) (blame-source b)) @@ -289,11 +293,17 @@ (define at-line (if (string=? source-message "") #f (format " at: ~a" source-message))) + + (define blame-parties (blame-positive blme)) + (define invariant-assertion-failure? (equal? blame-parties (list invariant-assertion-party))) (define self-or-not - (if (blame/important-original? blme) - "broke its own contract" - "contract violation")) + (cond + [invariant-assertion-failure? + "assertion violation"] + [(blame/important-original? blme) + "broke its own contract"] + [else "contract violation"])) (define start-of-message (cond @@ -304,9 +314,11 @@ [else (format "~a" self-or-not)])) - (define blame-parties (blame-positive blme)) (define blaming-line (cond + [invariant-assertion-failure? + ;; cause the blaming-line to be skipped + '()] [(null? (cdr blame-parties)) (format " blaming: ~a" (convert-blame-singleton (car blame-parties)))] [else @@ -315,6 +327,12 @@ " blaming multiple parties:" (for/list ([party (in-list blame-parties)]) (format "\n ~a" (convert-blame-singleton party))))])) + + (define assumption-line + (cond + [invariant-assertion-failure? + '()] + [else " (assuming the contract is correct)"])) (define on-line (and (blame-important blme) @@ -355,7 +373,7 @@ from-line on-line blaming-line - " (assuming the contract is correct)" + assumption-line at-line)) (define (blame-add-extra-field b name field)