suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

adjust *SL error-message rewriting

Browse Source
This commit is contained in:
Matthew Flatt 2012-06-03 10:53:23 +08:00
parent d1c2430bf1
commit cc0b887106
7 changed files with 42 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
collects/lang/private/rewrite-error-message.rkt
View File

@ -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 `#<image>' 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.))))

2
collects/lang/private/teach.rkt
View File

@ -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)

8
collects/tests/htdp-lang/advanced.rktl
View File

@ -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 <non-empty list>; given: 1")
(htdp-err/rt-test (rest 1) "rest: expected argument of type <non-empty list>; 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)))

6
collects/tests/htdp-lang/beg-adv.rktl
View File

@ -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$")

2
collects/tests/htdp-lang/beg-bega.rktl
View File

@ -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")

14
collects/tests/htdp-lang/htdp-test.rktl
View File

@ -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)

8
collects/tests/htdp-lang/intm-adv.rktl
View File

@ -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':