diff --git a/collects/drracket/private/colored-errors.rkt b/collects/drracket/private/colored-errors.rkt index 320024abb7..493151f6e1 100755 --- a/collects/drracket/private/colored-errors.rkt +++ b/collects/drracket/private/colored-errors.rkt @@ -81,8 +81,11 @@ (provide/contract [get-error-colored-srclocs (exn? . -> . (listof (list/c srcloc-syntax/c color/c)))]) (define (get-error-colored-srclocs exn) + (get-message-colored-srclocs (get-error-message/color exn))) + +(provide/contract [get-message-colored-srclocs (colored-error-message? . -> . (listof (list/c srcloc-syntax/c color/c)))]) +(define (get-message-colored-srclocs msg) (define (promote srcloc) (if (list? srcloc) srcloc (list srcloc #f))) - (define msg (get-error-message/color exn)) (map promote (append (append* @@ -183,8 +186,9 @@ (define color (and (list? the-arg) (findf symbol? the-arg))) (values (colored-msg-fragment (if (list? the-arg) (first the-arg) the-arg) sub is-important color) rest-args)) -(provide/contract [colored-format (([fmt string?]) (#:additional-highlights [additional-highlights additional-highlights/c]) #:rest [_ any/c] - . ->i . [_ colored-error-message?])]) +(define colored-format/c (([fmt string?]) (#:additional-highlights [additional-highlights additional-highlights/c]) #:rest [_ any/c] + . ->i . [_ colored-error-message?])) +(provide/contract [colored-format colored-format/c]) ;; colored-format : Takes a format string and a number of arguments, and produces a string where each ;; format marker has been replaced by their corresponding argument. This function support @@ -273,6 +277,7 @@ ;; The message and srcloc fields of the exception are populated from the information ;; in the fmt. additional-highlights specifies srclocs that should be highlighted, in addition ;; to the highlights used to explicate the correspondance between the text and the piece of codes. +(provide/contract [raise-colored-syntax-error colored-format/c]) (define (raise-colored-syntax-error fmt #:additional-highlights [additional-highlights empty] . args) (define formatted (apply colored-format fmt #:additional-highlights additional-highlights args)) (raise (exn:fail:colored:syntax (uncolor-message formatted) diff --git a/collects/lang/htdp-beginner.rkt b/collects/lang/htdp-beginner.rkt index 8261b119e8..3d9a5b7062 100644 --- a/collects/lang/htdp-beginner.rkt +++ b/collects/lang/htdp-beginner.rkt @@ -68,7 +68,7 @@ (lambda (stx) (syntax-case stx () [(id . args) - ((wrap-for-contract-error-message #'beginner-app) #'orig-name stx)] + (syntax/loc stx (beginner-app orig-name . args))] [_else (raise-syntax-error #f diff --git a/collects/lang/htdp-langs.rkt b/collects/lang/htdp-langs.rkt index 83a3ec987b..b0ad32daaa 100644 --- a/collects/lang/htdp-langs.rkt +++ b/collects/lang/htdp-langs.rkt @@ -23,7 +23,8 @@ ;; this module is shared between the drscheme's namespace (so loaded here) ;; and the user's namespace in the teaching languages - "private/set-result.rkt" + "private/set-result.ss" + "private/rewrite-error-message.rkt" "private/continuation-mark-key.rkt" @@ -1035,7 +1036,7 @@ ;; adds in the bug icon, if there are contexts to display (define (teaching-languages-error-display-handler msg exn) (if (exn? exn) - (display (exn-message exn) (current-error-port)) + (display (get-rewriten-error-message exn) (current-error-port)) (fprintf (current-error-port) "uncaught exception: ~e" exn)) (fprintf (current-error-port) "\n") diff --git a/collects/lang/private/rewrite-error-message-for-tpl.rkt b/collects/lang/private/rewrite-error-message-for-tpl.rkt deleted file mode 100755 index 6d4d56aee8..0000000000 --- a/collects/lang/private/rewrite-error-message-for-tpl.rkt +++ /dev/null @@ -1,36 +0,0 @@ -#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)) \ No newline at end of file diff --git a/collects/lang/private/rewrite-error-message.rkt b/collects/lang/private/rewrite-error-message.rkt index be16425aac..3e066d532d 100755 --- a/collects/lang/private/rewrite-error-message.rkt +++ b/collects/lang/private/rewrite-error-message.rkt @@ -2,28 +2,66 @@ (require mzlib/etc mzlib/list - (for-template scheme/base "rewrite-error-message-for-tpl.rkt") (for-syntax "firstorder.ss" scheme/base)) -(provide wrap-top-for-lookup-error-message - wrap-for-contract-error-message) +(provide rewrite-contract-error-message + reraise-rewriten-lookup-error-message + get-rewriten-error-message + plural + raise-not-bound-error + argcount-error-message) -(define (wrap-top-for-lookup-error-message stx was-in-app-position) - (syntax-case stx () - [(_ . 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 (reraise-rewriten-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 (exn-needs-rewriting? exn) + (exn:fail:contract? exn)) + +(define (plural n) + (if (> (string->number n) 1) "s" "")) -(define ((wrap-for-contract-error-message app) orig-name stx) - (syntax-case stx () - [(id . args) - (quasisyntax/loc stx - (with-handlers ([exn:fail:contract? (compose raise rewrite-contract-error-message)]) - #,(quasisyntax/loc stx (#,app #,orig-name . args))))])) +(define (raise-not-bound-error id) + (if (syntax-property id 'was-in-app-position) + (raise-syntax-error + #f + "this function is not defined" + id) + (raise-syntax-error + #f + "this variable is not defined" + id))) +(define (argcount-error-message arity found) + (define fn-is-large (> (string->number arity) (string->number found))) + (format "expects ~a~a argument~a, but found ~a~a" + (if fn-is-large "" "only ") + arity (plural arity) + (if fn-is-large "only " "") + found)) +(define (rewrite-contract-error-message msg) + (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 #px"expects at least (\\d+) argument.?, given (\\d+): .*" + (lambda (all one two) (format "expects at least ~a argument~a, but found only ~a." + one (plural one) two))) + (list #px"expects (\\d+) argument.?, given (\\d+): .*" + (lambda (all one two) (argcount-error-message one two))) + (list #rx"^procedure " + (lambda (all) "")) + )) + (for/fold ([msg msg]) ([repl. replacements]) + (regexp-replace* (first repl.) msg (second repl.)))) + +(define (get-rewriten-error-message exn) + (if (exn-needs-rewriting? exn) + (rewrite-contract-error-message (exn-message exn)) + (exn-message exn))) diff --git a/collects/lang/private/teach.rkt b/collects/lang/private/teach.rkt index 02408b7f55..da0a3bc3c0 100644 --- a/collects/lang/private/teach.rkt +++ b/collects/lang/private/teach.rkt @@ -54,13 +54,16 @@ beginner-equal? beginner-equal~? teach-equal? advanced-cons advanced-list*)) + (require "rewrite-error-message.rkt") + (require-for-syntax "teachhelp.ss" - "teach-shared.ss" "rewrite-error-message.rkt" + "teach-shared.ss" syntax/kerncase syntax/stx syntax/struct syntax/context + syntax/colored-errors mzlib/include scheme/list (rename racket/base racket:define-struct define-struct) @@ -107,6 +110,9 @@ #t))) (raise-syntax-error #f "this name was defined previously and cannot be re-defined" id))) + (define (top/check-defined id) + (namespace-variable-value (syntax-e id) #t (lambda () (raise-not-bound-error id)))) + ;; For quasiquote and shared: (require (rename "teachprims.rkt" the-cons advanced-cons)) (require (only "teachprims.rkt" cyclic-list?)) @@ -234,6 +240,7 @@ (raise-syntax-error form msg stx detail) (raise-syntax-error form msg stx)))) + (define (teach-syntax-error* form stx details msg . args) (let ([exn (with-handlers ([exn:fail:syntax? (lambda (x) x)]) @@ -1208,40 +1215,31 @@ ;; top-level variables (beginner) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Report errors for undefined names (but only in modules) - (define (beginner-top/proc stx) (syntax-case stx () [(_ . id) - ;; If we're in a module, we'll need to check that the name - ;; is bound.... - (if (and (not (identifier-binding #'id)) - (syntax-source-module #'id)) - ;; ... but it might be defined later in the module, so - ;; delay the check. - (stepper-ignore-checker - (syntax/loc stx (#%app values (beginner-top-continue id)))) - - (wrap-top-for-lookup-error-message - stx - (syntax-property #'id 'was-in-app-position)))])) + (if (not (identifier-binding #'id)) + (if (syntax-source-module #'id) + ;; If we're in a module, we'll need to check that the name + ;; is bound but it might be defined later in the module, so + ;; delay the check. + (stepper-ignore-checker + (syntax/loc stx (#%app values (beginner-top-continue id)))) + + ;; identifier-finding only returns useful information when inside a module. At the top-level we need to + ;; do the check at runtime. Also, note that at the top level there is no need for stepper annotations + (syntax/loc stx (#%app top/check-defined #'id))) + + (syntax/loc stx (#%top . id)))])) + (define (beginner-top-continue/proc stx) (syntax-case stx () [(_ id) - ;; If there's still no binding, it's an "unknown name" error. (if (not (identifier-binding #'id)) - (if (syntax-property #'id 'was-in-app-position) - (teach-syntax-error - #f - #'id - #f - "this function is not defined") - (teach-syntax-error - #f - #'id - #f - "this variable is not defined")) + ;; If there's still no binding, it's an "unknown name" error. + (raise-not-bound-error #'id) + ;; Don't use #%top here; id might have become bound to something ;; that isn't a value. #'id)])) diff --git a/collects/lang/private/teachhelp.rkt b/collects/lang/private/teachhelp.rkt index 87ccba83ee..b4b31a1718 100644 --- a/collects/lang/private/teachhelp.rkt +++ b/collects/lang/private/teachhelp.rkt @@ -1,5 +1,6 @@ (module teachhelp mzscheme - (require "firstorder.rkt" + (require "firstorder.ss" + "rewrite-error-message.rkt" stepper/private/shared) (require-for-syntax stepper/private/shared) @@ -67,13 +68,11 @@ stx #f)] [(id . rest) - (let ([l (length (syntax->list #'rest))]) - (unless (= l arity) + (let ([found (length (syntax->list #'rest))]) + (unless (= found arity) (raise-syntax-error #f - (format "this function expects ~a argument~a, here it is provided ~a argument~a" - arity (if (= 1 arity) "" "s") - l (if (= 1 l) "" "s")) + (argcount-error-message arity found) stx #f)) (datum->syntax-object