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

The new error messages now pass the tests/language-test.rkt suite

Browse Source 
(except for contract runtime error messages in levels higher than
 beginner.)
This commit is contained in:
Guillaume Marceau 2011-06-06 23:17:47 -04:00
parent f858b8bb5c
commit 6eea5b1793
11 changed files with 1589 additions and 1692 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
collects/lang/htdp-beginner.rkt
View File

@ -55,10 +55,6 @@
(require (for-syntax "private/firstorder.ss"))
;; This is essentially a specialized version of `define-primitive'
;; that refines the error messages for built-in things, which
;; we might like to call "contructor" or "predicate" instead of
;; just "primitive".
(define-syntax (in-rator-position-only stx)
(syntax-case stx ()
[(_ new-name orig-name)
@ -67,35 +63,19 @@
;; Some things are not really functions:
(if (memq (syntax-e orig) '(beginner:pi beginner:e beginner:null beginner:eof))
#'(define new-name orig-name)
(with-syntax ([(what something)
(case (syntax-e orig)
[(beginner:make-posn)
#'("constructor"
"called with values for the structure fields")]
[(beginner:posn-x beginner:posn-y)
#'("selector"
"applied to a structure to get the field value")]
[(beginner:posn?)
#'("predicate"
"applied to an argument")]
[else
#'("primitive operator"
"applied to arguments")])])
#'(define-syntax new-name
(make-first-order
(lambda (stx)
(syntax-case stx ()
[(id . args)
(syntax/loc stx
(with-handlers ([exn:fail:contract? (compose raise rewrite-contract-error-message)])
(beginner-app orig-name . args)))]
[_else
(raise-syntax-error
#f
(format
"found a use that does not follow an open parenthesis")
stx)]))
#'orig-name)))))]))
#'(define-syntax new-name
(make-first-order
(lambda (stx)
(syntax-case stx ()
[(id . args)
((wrap-for-contract-error-message #'beginner-app) #'orig-name stx)]
[_else
(raise-syntax-error
#f
(format
"found a use that does not follow an open parenthesis")
stx)]))
#'orig-name))))]))
;; procedures:
(provide-and-document/wrap

6
collects/lang/htdp-intermediate.rkt
View File

@ -3,11 +3,11 @@
(require "private/teach.ss"
"private/teachprims.ss"
"private/teach-module-begin.ss"
"private/rewrite-error-message.rkt"
mzlib/etc
mzlib/list
syntax/docprovide
test-engine/scheme-tests)
test-engine/scheme-tests
(for-syntax scheme/base))
;; syntax:
(provide (rename-out
@ -55,7 +55,7 @@
; check-property for-all ==> expect expect-within expect-member-of expect-range
)
;; procedures:
(provide-and-document
procedures
(all-from beginner: lang/private/intermediate-funs procedures))

36
collects/lang/private/rewrite-error-message-for-tpl.rkt Executable file
View File

@ -0,0 +1,36 @@
#lang scheme/base
(require scheme/list)
(provide rewrite-lookup-error-message
rewrite-contract-error-message)
(define (rewrite-lookup-error-message e id was-in-app-position)
(let ([var-or-function (if was-in-app-position "function" "variable")])
(raise-syntax-error
#f
(format "this ~a is not defined" var-or-function)
id)))
(define (change-contract-exn-messages e msg)
(define constructor
(cond [(exn:fail:contract:arity? e) make-exn:fail:contract:arity]
[(exn:fail:contract:divide-by-zero? e) make-exn:fail:contract:divide-by-zero]
[(exn:fail:contract:non-fixnum-result? e) make-exn:fail:contract:non-fixnum-result]
[(exn:fail:contract:continuation? e) make-exn:fail:contract:continuation]
[else make-exn:fail:contract]))
(constructor msg (exn-continuation-marks e)))
(define (rewrite-contract-error-message e)
(define replacements
(list (list #rx"expects argument of type (<([^>]+)>)"
(lambda (all one two) (format "expects a ~a" two)))
(list #rx"expects type (<([^>]+)>)"
(lambda (all one two) (format "expects a ~a" two)))
(list #rx"^procedure "
(lambda (all) ""))
))
(define new-message
(for/fold ([msg (exn-message e)]) ([repl. replacements])
(regexp-replace* (first repl.) msg (second repl.))))
(change-contract-exn-messages e new-message))

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

@ -1,68 +1,29 @@
#lang scheme/base
(require mzlib/etc mzlib/list)
(require (for-syntax scheme/base))
(require (for-syntax "firstorder.ss"))
(require mzlib/etc
mzlib/list
(for-template scheme/base "rewrite-error-message-for-tpl.rkt")
(for-syntax "firstorder.ss"
scheme/base))
(provide rewrite-contract-error-message
rewrite-lookup-error-message/rand
rewrite-lookup-error-message/rator
wrap-for-contract-error-message
wrap-for-lookup-error-message
::)
(provide wrap-top-for-lookup-error-message
wrap-for-contract-error-message)
(define (rewrite-lookup-error-message/rator e)
(rewrite-lookup-error-message e "function"))
(define (rewrite-lookup-error-message/rand e)
(rewrite-lookup-error-message e "variable"))
(define (rewrite-lookup-error-message e var-or-function)
(define new-message
(regexp-replace* #rx"reference to an identifier before its definition"
(exn-message e)
(format "this is ~a not defined" var-or-function)))
(struct-copy exn e [message new-message]))
(define-syntax (wrap-for-lookup-error-message stx)
(define (wrap-top-for-lookup-error-message stx was-in-app-position)
(syntax-case stx ()
[(_ . id)
(with-syntax ([top (syntax/loc stx #%top)])
(syntax/loc stx
(with-handlers ([exn:fail:contract:variable?
(compose raise rewrite-lookup-error-message)])
(top . id))))]))
(quasisyntax/loc
stx
(with-handlers ([exn:fail:contract:variable?
(lambda (e) (rewrite-lookup-error-message e #'id #,was-in-app-position))])
(#%top . id)))]))
(define (change-contract-exn-messages e msg)
(define constructor
(cond [(exn:fail:contract:arity? e) make-exn:fail:contract:arity]
[(exn:fail:contract:divide-by-zero? e) make-exn:fail:contract:divide-by-zero]
[(exn:fail:contract:non-fixnum-result? e) make-exn:fail:contract:non-fixnum-result]
[(exn:fail:contract:continuation? e) make-exn:fail:contract:continuation]
[else make-exn:fail:contract]))
(constructor msg (exn-continuation-marks e)))
(define (rewrite-contract-error-message e)
(define replacements
(list (list #rx"expects argument of type (<([^>]+)>)"
(lambda (all one two) (format "expects a ~a" two)))
(list #rx"expects type (<([^>]+)>)"
(lambda (all one two) (format "expects a ~a" two)))
(list #rx"^procedure "
(lambda (all) ""))
))
(define new-message
(for/fold ([msg (exn-message e)]) ([repl. replacements])
(regexp-replace* (first repl.) msg (second repl.))))
(change-contract-exn-messages e new-message))
(define-for-syntax (wrap-for-contract-error-message* stx)
(define ((wrap-for-contract-error-message app) orig-name stx)
(syntax-case stx ()
[(_ new old)
#'(define (new . args)
(with-handlers ([exn:fail:contract? (compose raise rewrite-contract-error-message)])
(apply old args)))]))
[(id . args)
(quasisyntax/loc stx
(with-handlers ([exn:fail:contract? (compose raise rewrite-contract-error-message)])
#,(quasisyntax/loc stx (#,app #,orig-name . args))))]))
(define-syntax wrap-for-contract-error-message wrap-for-contract-error-message*)
(define-syntax :: wrap-for-contract-error-message*) ;; to circumvent most of the ugliness of provide-and-document/wrap's renaming of the function's infered name

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

@ -40,7 +40,6 @@
scheme/match
"set-result.rkt"
(only racket/base define-struct)
"rewrite-error-message.rkt"
racket/struct-info
deinprogramm/signature/signature-english
(all-except deinprogramm/signature/signature signature-violation)
@ -54,16 +53,18 @@
(only lang/private/teachprims
beginner-equal? beginner-equal~? teach-equal?
advanced-cons advanced-list*))
(require-for-syntax "teachhelp.rkt"
"teach-shared.rkt"
syntax/kerncase
syntax/stx
syntax/struct
syntax/context
mzlib/include
scheme/list
(rename racket/base racket:define-struct define-struct)
(only racket/base syntax->datum datum->syntax)
(require-for-syntax "teachhelp.ss"
"teach-shared.ss"
"rewrite-error-message.rkt"
syntax/kerncase
syntax/stx
syntax/struct
syntax/context
mzlib/include
scheme/list
(rename racket/base racket:define-struct define-struct)
(only racket/base syntax->datum datum->syntax)
(rename racket/base kw-app #%app)
racket/struct-info
stepper/private/shared
@ -104,7 +105,7 @@
[exn:fail:syntax? (lambda (exn) #t)])
(namespace-variable-value (syntax-e id) #t)
#t)))
(error who "cannot redefine name: ~a" (syntax-e id))))
(raise-syntax-error #f "this name was defined previously and cannot be re-defined" id)))
;; For quasiquote and shared:
(require (rename "teachprims.rkt" the-cons advanced-cons))
@ -317,10 +318,10 @@
(let ([b (identifier-binding name)])
(when b
(teach-syntax-error
'duplicate
stx
(syntax-e name)
name
#f
"~a was defined previously and cannot be re-defined" (syntax-e name)))))
"this name was defined previously and cannot be re-defined"))))
names)
(if assign
(with-syntax ([(name ...) (if (eq? assign #t)
@ -1068,7 +1069,7 @@
(with-syntax ([(name? variant? ...)
(map (lambda (stx)
(datum->syntax stx (string->symbol (format "~a?" (syntax->datum stx)))))
(datum->syntax stx (string->symbol (format "~a?" (syntax->datum stx))) stx))
(syntax->list #'(name variant ...)))])
;; Here we are using an explicit loop and the "/proc" functions instead of producing a syntax with "..."
;; to preserve the syntax location information.
@ -1220,14 +1221,10 @@
;; delay the check.
(stepper-ignore-checker
(syntax/loc stx (#%app values (beginner-top-continue id))))
(with-syntax ([rewriter
(if (syntax-property #'id 'was-in-app-position)
'rewrite-lookup-error-message/rator
'rewrite-lookup-error-message/rand)])
(syntax/loc stx
(with-handlers ([exn:fail:contract:variable?
(compose raise rewriter)])
(#%top . id)))))]))
(wrap-top-for-lookup-error-message
stx
(syntax-property #'id 'was-in-app-position)))]))
(define (beginner-top-continue/proc stx)
(syntax-case stx ()
@ -2049,7 +2046,7 @@
"found a variable that is used more than once: ~a"
(syntax-e dup))))
(check-single-expression 'lambda
"after the variables"
"for the function body"
stx
(syntax->list (syntax (lexpr ...)))
args)
@ -2227,7 +2224,7 @@
;; new syntax object that is an `intermediate-define' form;
;; that's important for syntax errors, so that they
;; report `advanced-define' as the source.
(define/proc #f #t stx #'beginner-lambda)]
(define/proc #f #t stx #'beginner-lambda)]
[_else
(bad-use-error 'define stx)]))
@ -2260,7 +2257,7 @@
"found a variable that is used more than once: ~a"
(syntax-e dup))))
(check-single-expression 'lambda
"after the variables"
"for the function body"
stx
(syntax->list (syntax exprs))
names)
@ -2339,18 +2336,19 @@
'set!
stx
(syntax id)
"expected a mutable variable after set!, but found a variable that cannot be modified")))
"expected a mutable variable after set!, but found a variable that cannot be modified: ~a"
(syntax-e #'id))))
;; If we're in a module, we'd like to check here whether
;; the identier is bound, but we need to delay that check
;; in case the id is defined later in the module. So only
;; do this in continuing mode:
(when continuing?
(when continuing?
(let ([binding (identifier-binding #'id)])
(cond
[(and (not binding)
(syntax-source-module #'id))
(teach-syntax-error
'unknown
#f
#'id
#f
"this variable is not defined")]
@ -2359,23 +2357,26 @@
(let-values ([(path rel) (module-path-index-split (car binding))])
path)))
(teach-syntax-error
'unknown
'set!
#'id
#f
"expected a mutable variable after set!, but found a variable that cannot be modified")])))
"expected a mutable variable after set!, but found a variable that cannot be modified: ~a"
(syntax-e #'id))])))
;; Check the RHS
(check-single-expression 'set!
"for the new value"
stx
exprs
null)
(if continuing?
(stepper-syntax-property
(syntax/loc stx (begin (set! id expr ...) set!-result))
(quasisyntax/loc stx (begin #,(datum->syntax #'here `(set! ,#'id ,@(syntax->list #'(expr ...))) stx) set!-result))
'stepper-skipto
(append skipto/cdr
skipto/first))
(stepper-ignore-checker (syntax/loc stx (#%app values (advanced-set!-continue id expr ...))))))]
(stepper-ignore-checker (quasisyntax/loc stx (#%app values #,(advanced-set!-continue/proc
(syntax/loc stx (_ id expr ...))))))))]
[(_ id . __)
(teach-syntax-error
'set!
@ -2574,7 +2575,7 @@
'case
stx
choices
"expected at least one choice (in parentheses), but nothing's there"))
"expected a symbol (without its quote) or a number as a choice, but nothing's there"))
(check-single-expression 'case
"for the answer in the case clause"
clause

3002
collects/tests/drracket/language-test.rkt
View File

File diff suppressed because it is too large Load Diff

2
collects/tests/gracket/testing.rktl
View File

@ -49,6 +49,8 @@
(test vals 'method (call-with-values (lambda () (send obj method . args)) list)))])))
(define (report-errs)
(flush-output)
(sleep 1)
(newline)
(if (null? errs)
(printf "Passed all ~a tests\n" test-count)

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

@ -61,15 +61,19 @@
(htdp-test 2 'begin0 (begin0 2 1))
(htdp-test 3 'begin0 (begin0 3 2 1))
(htdp-syntax-test #'set! "set!: found a use that does not follow an open parenthesis")
(htdp-syntax-test #'(set!) "set!: expected a variable after set!, but nothing's there")
(htdp-syntax-test #'(set! x) "set!: expected an expression for the new value, but nothing's there")
(htdp-syntax-test #'(set! 1 2) "set!: expected a variable after set!, but found a number")
(htdp-syntax-test #'(set! x 2 3) "set!: expected only one expression for the new value, but found 1 extra part")
(htdp-syntax-test #'(set! set! 2) "set!: expected a variable after set!, but found a set!")
(htdp-syntax-test #'(lambda (x) (set! x 2)) "set!: expected a mutable variable after set!, but found a variable that cannot be modified")
(htdp-syntax-test #'(set! x 1) "x: this variable is not defined")
(htdp-syntax-test #'(lambda (x) (set! x 2)) "set!: expected a mutable variable after set!, but found a variable that cannot be modified: x")
(htdp-syntax-test #'(let ([x 5]) (lambda (x) (set! x 2))) "set!: expected a mutable variable after set!, but found a variable that cannot be modified")
(htdp-top (define x 5))
(htdp-top (set! x 'hello))
(htdp-test 'hello 'access-x x)
(htdp-test 18 'set! (local [(define x 12)]
@ -95,16 +99,7 @@
(htdp-top (set! x 13))
(htdp-test 12 force d)
(htdp-test 13 'access-x x)
"let: bad syntax (not a sequence of identifier--expression bindings)"
(htdp-top-pop 4)
(htdp-syntax-test #'(let name) "let: expected at least one binding (in parentheses) after let, but nothing's there")
(htdp-syntax-test #'(let name 10) "let: expected at least one binding (in parentheses) after let, but found a number")
@ -129,7 +124,7 @@
(htdp-syntax-test #'(case 5 [(5)]) "case: expected an expression for the answer in the case clause, but nothing's there")
(htdp-syntax-test #'(case 5 [(5) 12 13]) "case: expected only one expression for the answer in the case clause, but found 1 extra part")
(htdp-syntax-test #'(case 5 [("a") 10]) "case: expected a symbol (without its quote) or a number as a choice, but found a string")
(htdp-syntax-test #'(case 5 [() 10]) "case: expected at least one choice, but nothing's there")
(htdp-syntax-test #'(case 5 [() 10]) "expected a symbol (without its quote) or a number as a choice, but nothing's there")
(htdp-syntax-test #'(case 5 [(5 "a") 10]) "case: expected a symbol (without its quote) or a number as a choice, but found a string")
(htdp-syntax-test #'(case 5 [else 12][(5) 10]) "case: found an else clause that isn't the last clause in its case expression")
(htdp-syntax-test #'(case 5 [(5) 10][else 12][else 13]) "case: found an else clause that isn't the last clause in its case expression")
@ -432,12 +427,11 @@
(htdp-syntax-test #'(define-datatype dt [(v1)]) #rx"define-datatype: expected a variant name, found a part")
(htdp-syntax-test #'(define-datatype dt [v1 10]) #rx"define-datatype: in variant `v1': expected a field name, found a number")
(htdp-syntax-test #'(define-datatype dt [v1] [v1]) #rx"define-datatype: found a variant name that is used more than once: v1")
(htdp-syntax-test #'(define-datatype posn [v1]) #rx"posn\\?: this name has a built-in meaning and cannot be re-defined")
(htdp-syntax-test #'(define-datatype dt [posn]) #rx"posn: this name has a built-in meaning and cannot be re-defined")
(htdp-syntax-test #'(define-datatype posn [v1]) "posn?: this name was defined previously and cannot be re-defined")
(htdp-syntax-test #'(define-datatype dt [posn]) "posn: this name was defined previously and cannot be re-defined")
(htdp-syntax-test #'(define-datatype lambda [v1]) #rx"define-datatype: expected a datatype type name after `define-datatype', but found a keyword")
(htdp-syntax-test #'(define-datatype dt [lambda]) #rx"define-datatype: expected a variant name, found a keyword")
(htdp-syntax-test #'(define-datatype (dt)) #rx"define-datatype: expected a datatype type name after `define-datatype',
but found a part")
(htdp-syntax-test #'(define-datatype (dt)) #rx"define-datatype: expected a datatype type name after `define-datatype', but found a part")
(htdp-syntax-test #'(+ 1 (define-datatype dt [v1])) #rx"define-datatype: found a definition that is not at the top level")
(htdp-top (define-datatype dt))
@ -474,15 +468,15 @@ but found a part")
(htdp-syntax-test #'(match 1 x) #rx"match: expected a pattern--answer clause, but found something else")
(htdp-syntax-test #'(match 1 []) #rx"match: expected a pattern--answer clause, but found an empty clause")
(htdp-syntax-test #'(match 1 [x]) #rx"expected an expression for the answer in a `match' clause, but nothing's there")
(htdp-syntax-test #'(match 1 [x 10 10]) #rx"expected only one expression for the answer in a `match' clause, but found one extra part")
(htdp-syntax-test #'(match 1 [x 10 x]) #rx"expected only one expression for the answer in a `match' clause, but found one extra part")
(htdp-syntax-test #'(match 1 [x 10 10]) #rx"expected only one expression for the answer in a `match' clause, but found 1 extra part")
(htdp-syntax-test #'(match 1 [x 10 x]) #rx"expected only one expression for the answer in a `match' clause, but found 1 extra part")
(htdp-syntax-test #'(match 1 [x 10] 10) #rx"match: expected a pattern--answer clause, but found a number")
(htdp-syntax-test #'(match 1 [x 10] x) #rx"match: expected a pattern--answer clause, but found something else")
(htdp-syntax-test #'(match 1 [x 10] []) #rx"match: expected a pattern--answer clause, but found an empty clause")
(htdp-syntax-test #'(match 1 [x 10] [x]) #rx"expected an expression for the answer in a `match' clause, but nothing's there")
(htdp-syntax-test #'(match 1 [x 10] [x 10 10]) #rx"expected only one expression for the answer in a `match' clause, but found one extra part")
(htdp-syntax-test #'(match 1 [x 10] [x 10 x]) #rx"expected only one expression for the answer in a `match' clause, but found one extra part")
(htdp-syntax-test #'(match 1 [x 10] [x 10 10]) #rx"expected only one expression for the answer in a `match' clause, but found 1 extra part")
(htdp-syntax-test #'(match 1 [x 10] [x 10 x]) #rx"expected only one expression for the answer in a `match' clause, but found 1 extra part")
(define-syntax-rule (htdp-match/v res pat expr val)
(htdp-test res 'pat (match expr [pat val] [else #f])))

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

@ -21,12 +21,12 @@
(htdp-syntax-test #'(define 1 10) "define: expected a variable name, or a function name and its variables (in parentheses), but found a number")
(htdp-syntax-test #'(define x lambda) "lambda: found a use that does not follow an open parenthesis")
(htdp-syntax-test #'(define x (lambda)) "lambda: expected at least one variable (in parentheses) after lambda, but nothing's there")
(htdp-syntax-test #'(define x (lambda (x))) "lambda: expected an expression after the variables, but nothing's there")
(htdp-syntax-test #'(define x (lambda (x))) "lambda: expected an expression for the function body, but nothing's there")
(htdp-syntax-test #'(define x (lambda y)) "lambda: expected at least one variable (in parentheses) after lambda, but found something else")
(htdp-syntax-test #'(define x (lambda y 10) "lambda: expected at least one variable (in parentheses) after lambda, but found something else"))
(htdp-syntax-test #'(define x (lambda (10) 10)) "lambda: expected a variable, but found a number")
(htdp-syntax-test #'(define x (lambda (x 10) 10)) "lambda: expected a variable, but found a number")
(htdp-syntax-test #'(define x (lambda (y) 10 11)) "lambda: expected only one expression after the variables, but found 1 extra part")
(htdp-syntax-test #'(define x (lambda (y) 10 11)) "lambda: expected only one expression for the function body, but found 1 extra part")
(htdp-syntax-test #'(define x (lambda (y y) 10)) "lambda: found a variable that is used more than once: y")
(htdp-syntax-test #'(+ (define x 5)) "define: found a definition that is not at the top level")
@ -67,6 +67,7 @@
(htdp-test 15 'app-f (f 10))
(htdp-top-pop 1)
(htdp-top-pop 1)
(htdp-top-pop 1)
(htdp-top (define-struct a0 ()))
(htdp-top (define-struct a1 (b)))

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

@ -16,7 +16,7 @@
(htdp-test '(quasiquote (unquote 22)) 'qq ``,,(* 11 2))
(htdp-test '(quasiquote ((unquote-splicing (22)))) 'qq ``(,@(,@(list (* 11 2)))))
(htdp-syntax-test #'quasiquote "quasiquote: found a use that does not precede an open parenthesis")
(htdp-syntax-test #'quasiquote "quasiquote: found a use that does not follow an open parenthesis")
(htdp-syntax-test #'`unquote "quasiquote: misuse of unquote within a quasiquoting backquote")
(htdp-syntax-test #'`unquote-splicing "quasiquote: misuse of ,@ or unquote-splicing within a quasiquoting backquote")
(htdp-syntax-test #'`(unquote-splicing 10) "quasiquote: misuse of ,@ or unquote-splicing within a quasiquoting backquote")

2
collects/tests/htdp-lang/beginner.rktl
View File

@ -91,7 +91,7 @@
(load-relative "beg-intm.rktl")
(load-relative "beg-bega.rktl")
(htdp-syntax-test #'quote "found a use that isn't before a parenthesis")
(htdp-syntax-test #'quote "quote: found a use that does not follow an open parenthesis")
(htdp-syntax-test #''1 "quote: expected the name of the symbol after the quote, but found a number")
(htdp-syntax-test #''"hello" "quote: expected the name of the symbol after the quote, but found a string")
(htdp-syntax-test #''(1 2) "quote: expected the name of the symbol after the quote, but found a part")