diff --git a/.gitignore b/.gitignore index ce6902a12e..b331c565d3 100644 --- a/.gitignore +++ b/.gitignore @@ -10,7 +10,8 @@ # a common convenient place to set the PLTADDON directory to /add-on/ -# common backups, autosaves, and lock files +# common backups, autosaves, lock files, OS meta-files *~ \#* .#* +.DS_Store diff --git a/collects/racket/contract/private/base.rkt b/collects/racket/contract/private/base.rkt index 293b66f0a1..14f71a3b04 100644 --- a/collects/racket/contract/private/base.rkt +++ b/collects/racket/contract/private/base.rkt @@ -27,21 +27,21 @@ improve method arity mismatch contract violation error messages? (syntax-case stx () [(_ c v pos neg name loc) (syntax/loc stx - (apply-contract c v pos neg name loc))] + (apply-contract c v pos neg name loc (current-contract-region)))] [(_ c v pos neg) (syntax/loc stx - (apply-contract c v pos neg #f (build-source-location #f)))] + (apply-contract c v pos neg #f (build-source-location #f) (current-contract-region)))] [(_ c v pos neg src) (raise-syntax-error 'contract (string-append "please update contract application to new protocol " "(either 4 or 6 arguments)"))])) -(define (apply-contract c v pos neg name loc) +(define (apply-contract c v pos neg name loc usr) (let* ([c (coerce-contract 'contract c)]) (check-source-location! 'contract loc) (((contract-projection c) - (make-blame loc name (contract-name c) pos neg #t)) + (make-blame loc name (contract-name c) pos neg usr #t)) v))) (define-syntax (recursive-contract stx) diff --git a/collects/racket/contract/private/blame.rkt b/collects/racket/contract/private/blame.rkt index a0311aa122..5e6f106965 100644 --- a/collects/racket/contract/private/blame.rkt +++ b/collects/racket/contract/private/blame.rkt @@ -34,7 +34,7 @@ (hash/recur (blame-original? b)))) (define-struct blame - [source value contract positive negative original?] + [source value contract positive negative user original?] #:property prop:equal+hash (list blame=? blame-hash blame-hash)) @@ -64,12 +64,17 @@ [contract-message (show/write (blame-contract b))] [value-message (if (blame-value b) (format " on ~a" (show/display (blame-value b))) - "")]) - (format "~a~a broke the contract ~a~a; ~a" + "")] + [user-message (if (or (blame-original? b) + (equal? (blame-positive b) (blame-user b))) + "" + (format " given to ~a" (show/display (blame-user b))))]) + (format "~a~a broke the contract ~a~a~a; ~a" source-message positive-message contract-message value-message + user-message custom-message))) (define ((show f) v) diff --git a/collects/racket/contract/private/legacy.rkt b/collects/racket/contract/private/legacy.rkt index 5b80fbbe46..d912b62e41 100644 --- a/collects/racket/contract/private/legacy.rkt +++ b/collects/racket/contract/private/legacy.rkt @@ -21,7 +21,8 @@ name (unpack-blame pos) "<>" - #t) + #t + name) x fmt args)) @@ -58,7 +59,8 @@ name (unpack-blame (if original? pos neg)) (unpack-blame (if original? neg pos)) - original?))))) + original? + name))))) (define (legacy-property name) (define-values [ prop pred get ] diff --git a/collects/redex/tests/tl-test.rkt b/collects/redex/tests/tl-test.rkt index 3fc208f7dd..a9d31f92c8 100644 --- a/collects/redex/tests/tl-test.rkt +++ b/collects/redex/tests/tl-test.rkt @@ -646,13 +646,13 @@ (parameterize ([current-output-port sp] [current-traced-metafunctions 'all]) (term (f 1))) - (test (get-output-string sp) ">(f 1)\n<0\n")) + (test (get-output-string sp) ">`(f 1)\n<0\n")) (let ([sp (open-output-string)]) (parameterize ([current-output-port sp] [current-traced-metafunctions '(f)]) (term (f 1))) - (test (get-output-string sp) ">(f 1)\n<0\n"))) + (test (get-output-string sp) ">`(f 1)\n<0\n"))) (let () (define-language var-lang [(x y z w) variable]) @@ -1753,7 +1753,7 @@ [c (make-coverage T)]) (parameterize ([relation-coverage (list c)]) (apply-reduction-relation T (term q)) - (test (and (regexp-match #px"tl-test.ss:\\d+:\\d+" (caar (covered-cases c))) #t) + (test (and (regexp-match #px"tl-test.(?:.+):\\d+:\\d+" (caar (covered-cases c))) #t) #t)))) (let* ([R (reduction-relation @@ -1772,7 +1772,7 @@ second (curry regexp-match #px".*:(\\d+):\\d+"))]) (< (line-no (car c)) (line-no (car d)))))] - [src-ok? (curry regexp-match? #px"tl-test.ss:\\d+:\\d+")] + [src-ok? (curry regexp-match? #px"tl-test.(?:.+):\\d+:\\d+")] [sorted-counts (λ (cc) (map cdr (sort (covered-cases cc) <)))]) (define-metafunction empty-language [(f 1) 1] @@ -1851,7 +1851,7 @@ (test (capture-output (test-->> red 1 2) (test-results)) "One test passed.\n") (test (capture-output (test-->> red 2 3) (test-results)) - #rx"FAILED tl-test.ss:[0-9.]+\nexpected: 3\n actual: 2\n1 test failed \\(out of 1 total\\).\n")) + #rx"FAILED tl-test.(?:.+):[0-9.]+\nexpected: 3\n actual: 2\n1 test failed \\(out of 1 total\\).\n")) (let () (define red-share (reduction-relation @@ -1870,7 +1870,7 @@ (test (capture-output (test-->> red-cycle #:cycles-ok (term a)) (test-results)) "One test passed.\n") (test (capture-output (test-->> red-cycle (term a)) (test-results)) - #rx"FAILED tl-test.ss:[0-9.]+\nfound a cycle in the reduction graph\n1 test failed \\(out of 1 total\\).\n")) + #rx"FAILED tl-test.(?:.+):[0-9.]+\nfound a cycle in the reduction graph\n1 test failed \\(out of 1 total\\).\n")) (let () (define-metafunction empty-language [(f any) ((any))]) @@ -1913,7 +1913,7 @@ (test (capture-output (test--> R #:equiv mod2=? 7 1 0) (test-results)) "One test passed.\n") (test (capture-output (test--> R #:equiv mod2=? 7 1) (test-results)) - #rx"FAILED tl-test.ss:[0-9.]+\nexpected: 1\n actual: 8\n actual: 7\n1 test failed \\(out of 1 total\\).\n")) + #rx"FAILED tl-test.(?:.+):[0-9.]+\nexpected: 1\n actual: 8\n actual: 7\n1 test failed \\(out of 1 total\\).\n")) (let-syntax ([test-bad-equiv-arg (λ (stx)