diff --git a/collects/lang/private/rewrite-error-message.rkt b/collects/lang/private/rewrite-error-message.rkt index 499350594c..49c433d2a2 100644 --- a/collects/lang/private/rewrite-error-message.rkt +++ b/collects/lang/private/rewrite-error-message.rkt @@ -39,11 +39,12 @@ "this variable is not defined" id))) -(define (argcount-error-message arity found [at-least #f]) +(define (argcount-error-message name arity found [at-least #f]) (define arity:n (ensure-number arity)) (define found:n (ensure-number found)) (define fn-is-large (> arity:n found:n)) - (format "expects ~a~a~a argument~a, but found ~a~a" + (format "~a~aexpects ~a~a~a argument~a, but found ~a~a" + (or name "") (if name ": " "") (if at-least "at least " "") (if (or (= arity:n 0) fn-is-large) "" "only ") (if (= arity:n 0) "no" arity:n) (plural arity:n) @@ -52,13 +53,10 @@ (define (rewrite-contract-error-message msg) (define replacements - (list (list #rx"procedure application: expected procedure, given: (.*) \\(no arguments\\)" + (list (list #rx"application: expected procedure\n given: ([^\n]*)(?:\n arguments: [[]none[]])?" (lambda (all one) (format "function call: expected a function after the open parenthesis, but received ~a" one))) - (list #rx"procedure application: expected procedure, given: (.*); arguments were:.*" - (lambda (all one) - (format "function call: expected a function after the open parenthesis, but received ~a" one))) - (list #rx"reference to an identifier before its definition: (.*)" + (list #rx"reference to an identifier before its definition\n identifier: ([^\n]*)" (lambda (all one) (format "~a is used here before its definition" one))) (list #rx"expects argument of type (<([^>]+)>)" (lambda (all one two) (format "expects a ~a" two))) @@ -66,10 +64,10 @@ (lambda (all one two) (format "expects a ~a" two))) (list #rx"expects type (<([^>]+)>)" (lambda (all one two) (format "expects a ~a" two))) - (list #px"expects at least (\\d+) argument.?, given (\\d+)(: .*)?" - (lambda (all one two three) (argcount-error-message one two #t))) - (list #px"expects (\\d+) argument.?, given (\\d+)(: .*)?" - (lambda (all one two three) (argcount-error-message one two))) + (list #px"application: wrong number of arguments.*\n procedure: ([^\n]*)\n expected[^:]*: at least (\\d+)\n given[^:]*: (\\d+)" + (lambda (all one two three) (argcount-error-message one two three #t))) + (list #px"application: wrong number of arguments.*\n procedure: ([^\n]*)\n expected[^:]*: (\\d+)\n given[^:]*: (\\d+)(?:\n arguments:(?:\n [^\n]*)*)?" + (lambda (all one two three) (argcount-error-message one two three))) (list #rx"^procedure " (lambda (all) "")) (list #rx", given: " @@ -80,18 +78,13 @@ (lambda (all one) "expects a ")) (list #rx"list or cyclic list" (lambda (all) "list")) - (list (regexp-quote "given #(struct:object:image% ...)") - (lambda (all) "given an image")) - (list (regexp-quote "given #(struct:object:image-snip% ...)") - (lambda (all) "given an image")) - (list (regexp-quote "given #(struct:object:cache-image-snip% ...)") - (lambda (all) "given an image")) + ;; When do these show up? I see only `#' errors, currently. (list (regexp-quote "#(struct:object:image% ...)") - (lambda (all) "(image)")) + (lambda (all) "an image")) (list (regexp-quote "#(struct:object:image-snip% ...)") - (lambda (all) "(image)")) + (lambda (all) "an image")) (list (regexp-quote "#(struct:object:cache-image-snip% ...)") - (lambda (all) "(image)")))) + (lambda (all) "an image")))) (for/fold ([msg msg]) ([repl. replacements]) (regexp-replace* (first repl.) msg (second repl.)))) diff --git a/collects/lang/private/teach.rkt b/collects/lang/private/teach.rkt index 8955647722..5884aeee54 100644 --- a/collects/lang/private/teach.rkt +++ b/collects/lang/private/teach.rkt @@ -1428,7 +1428,7 @@ where stx #f - (argcount-error-message 2 n #t))) + (argcount-error-message #f 2 n #t))) (let loop ([clauses-consumed 0] [remaining (syntax->list #`clauses)]) (if (null? remaining) diff --git a/collects/tests/htdp-lang/advanced.rktl b/collects/tests/htdp-lang/advanced.rktl index 0fc5557af6..95520ca92f 100644 --- a/collects/tests/htdp-lang/advanced.rktl +++ b/collects/tests/htdp-lang/advanced.rktl @@ -205,11 +205,11 @@ (load (build-path (collection-path "tests" "racket") "shared-tests.rktl")) -(htdp-err/rt-test (cons 1 2) "cons: second argument must be a list or cyclic list, but received 1 and 2") -(htdp-err/rt-test (append (list 1) 2) "append: last argument must be a list or cyclic list, but received 2") +(htdp-err/rt-test (cons 1 2) "cons: second argument must be a list, but received 1 and 2") +(htdp-err/rt-test (append (list 1) 2) "append: last argument must be a list, but received 2") -(htdp-err/rt-test (first 1) "first: expected argument of type ; given: 1") -(htdp-err/rt-test (rest 1) "rest: expected argument of type ; given: 1") +(htdp-err/rt-test (first 1) "first: expects a non-empty list; given: 1") +(htdp-err/rt-test (rest 1) "rest: expects a non-empty list; given: 1") (htdp-test #t 'equal? (equal? (vector (list 10) 'apple) (vector (list 10) 'apple))) diff --git a/collects/tests/htdp-lang/beg-adv.rktl b/collects/tests/htdp-lang/beg-adv.rktl index 5bdb2975d4..cae0c85102 100644 --- a/collects/tests/htdp-lang/beg-adv.rktl +++ b/collects/tests/htdp-lang/beg-adv.rktl @@ -1,4 +1,9 @@ +(htdp-err/rt-test (add1) "add1: expects 1 argument, but found none") +(htdp-err/rt-test (add1 'a 'b 'c) "add1: expects only 1 argument, but found 3") +(htdp-err/rt-test (define x x) "x is used here before its definition") +(htdp-err/rt-test (add1 'a) "add1: contract violation") + (htdp-syntax-test #'() "function call: expected a function after the open parenthesis, but nothing's there") (htdp-syntax-test #'#%app) @@ -391,4 +396,3 @@ #rx"^several numbers 1234567$") (htdp-err/rt-test (error "several numbers " 1 " 2 " 3 " 4") #rx"^several numbers 1 2 3 4$") - diff --git a/collects/tests/htdp-lang/beg-bega.rktl b/collects/tests/htdp-lang/beg-bega.rktl index 55a443f0b4..a3610e8dfe 100644 --- a/collects/tests/htdp-lang/beg-bega.rktl +++ b/collects/tests/htdp-lang/beg-bega.rktl @@ -1,4 +1,6 @@ +(htdp-err/rt-test (/) "/: expects at least 2 arguments, but found none") + (htdp-syntax-test #'(local [(define x 5)] x) "local: this function is not defined") (htdp-syntax-test #'(recur name ([x 18]) x) "recur: this function is not defined") diff --git a/collects/tests/htdp-lang/htdp-test.rktl b/collects/tests/htdp-lang/htdp-test.rktl index e6e6008f11..82cb35c1ff 100644 --- a/collects/tests/htdp-lang/htdp-test.rktl +++ b/collects/tests/htdp-lang/htdp-test.rktl @@ -1,4 +1,6 @@ +(require lang/private/rewrite-error-message) + (define (strip-context v) ;; Just to be sure, remove all top-level context from the syntax object (cond @@ -64,7 +66,8 @@ #,(strip-context stx)) (lambda (x) (and (exn:fail:syntax? x) - (regexp-match (if (string? rx) (regexp-quote rx) rx) (exn-message x)) + (regexp-match (if (string? rx) (regexp-quote rx) rx) + (get-rewriten-error-message x)) (let ([locs ((exn:srclocs-accessor x) x)]) (and (not (empty? locs)) (andmap (lambda (s) (and (srcloc-source s) @@ -103,7 +106,11 @@ (define (htdp-string-to-pred exn?/rx) (if (or (regexp? exn?/rx) (string? exn?/rx)) (lambda (x) - (regexp-match exn?/rx (exn-message x))) + (if (regexp-match exn?/rx (get-rewriten-error-message x)) + #t + (begin + (printf "written: ~s\n" (get-rewriten-error-message x)) + #f))) exn?/rx)) (define-syntax (htdp-err/rt-test stx) @@ -116,7 +123,8 @@ (define (exn-type-and-msg type-pred msg) (lambda (exn) (and (type-pred exn) - (regexp-match (if (string? msg) (regexp-quote msg) msg) (exn-message exn))))) + (regexp-match (if (string? msg) (regexp-quote msg) msg) + (get-rewriten-error-message exn))))) (define (htdp-error-test stx) diff --git a/collects/tests/htdp-lang/intm-adv.rktl b/collects/tests/htdp-lang/intm-adv.rktl index a04a917c53..24ea1e2708 100644 --- a/collects/tests/htdp-lang/intm-adv.rktl +++ b/collects/tests/htdp-lang/intm-adv.rktl @@ -1,4 +1,8 @@ +(htdp-err/rt-test (/) "/: expects at least 1 argument, but found none") +(htdp-err/rt-test (pi) #px"function call: expected a function after the open parenthesis, but received 3[.]14\\d+$") +(htdp-err/rt-test (pi 1 2) #px"function call: expected a function after the open parenthesis, but received 3[.]14\\d+\n arguments:\n 1\n 2$") + ;; These are true for beginner, but the operators are syntax, so ;; arity-test doesn't work. @@ -112,8 +116,8 @@ (htdp-test 1 '+ (+ 1)) (htdp-test 1 '* (*)) (htdp-test 1 '* (* 1)) -(htdp-err/rt-test (-) (exn-type-and-msg exn:application:arity? #rx"wrong number of arguments.*procedure: -\n.*expected[^:]*: at least 1.*given[^:]*: 0")) -(htdp-err/rt-test (/) (exn-type-and-msg exn:application:arity? #rx"wrong number of arguments.*procedure: /\n.*expected[^:]*: at least 1.*given[^:]*: 0")) +(htdp-err/rt-test (-) (exn-type-and-msg exn:application:arity? #rx"-: expects at least 1 argument, but found none")) +(htdp-err/rt-test (/) (exn-type-and-msg exn:application:arity? #rx"/: expects at least 1 argument, but found none")) ;(htdp-test 1 (/ 1) exn:application:arity?) ;; Check that `local' works with macros that expand to `begin':