The rewriting machanism no longer inserts with-handler everywhere.

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]
+(define colored-format/c (([fmt string?]) (#:additional-highlights [additional-highlights additional-highlights/c]) #:rest [_ any/c]
-                                                   . ->i . [_ colored-error-message?])])
+                                                   . ->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)

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

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

collects/lang/private/rewrite-error-message-for-tpl.rkt

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

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
+(provide rewrite-contract-error-message
-         wrap-for-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)
+(define (reraise-rewriten-lookup-error-message e id was-in-app-position)
-  (syntax-case stx ()
+  (let ([var-or-function (if was-in-app-position "function" "variable")])
-    [(_ . id)
+    (raise-syntax-error
-     (quasisyntax/loc 
+     #f
-      stx
+     (format "this ~a is not defined" var-or-function)
-      (with-handlers ([exn:fail:contract:variable?
+     id)))
-                       (lambda (e) (rewrite-lookup-error-message e #'id #,was-in-app-position))])
-                     (#%top . id)))]))
 
+(define (exn-needs-rewriting? exn)
+  (exn:fail:contract? exn))
   
-(define ((wrap-for-contract-error-message app) orig-name stx)
+(define (plural n)
-  (syntax-case stx ()
+  (if (> (string->number n) 1) "s" ""))
-    [(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)))

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 (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....
+                 ;;  is bound but it might be defined later in the module, so
-         (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 
+                 ;; identifier-finding only returns useful information when inside a module. At the top-level we need to
-              stx
+                 ;; do the check at runtime. Also, note that at the top level there is no need for stepper annotations
-              (syntax-property #'id 'was-in-app-position)))]))
+                 (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)
+             ;; If there's still no binding, it's an "unknown name" error.
-                 (teach-syntax-error
+             (raise-not-bound-error #'id)
-                  #f
+             
-                  #'id
-                  #f
-                  "this function is not defined")
-                 (teach-syntax-error
-                  #f
-                  #'id
-                  #f
-                  "this variable is not defined"))
              ;; Don't use #%top here; id might have become bound to something
              ;;  that isn't a value.
              #'id)]))

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))])
+	   (let ([found (length (syntax->list #'rest))])
-	     (unless (= l arity)
+	     (unless (= found arity)
 	       (raise-syntax-error
 		#f
-		(format "this function expects ~a argument~a, here it is provided ~a argument~a"
+                (argcount-error-message arity found)
-			arity (if (= 1 arity) "" "s")
-			l (if (= 1 l) "" "s"))
 		stx
 		#f))
 	     (datum->syntax-object