From 9673f7e70317819add90157964bf0c8dd6e8121b Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Wed, 24 Jan 2007 07:52:51 +0000
Subject: [PATCH] removed the tweaker hack for a solution that creates a new
 exception

svn: r5446
---
 collects/handin-server/checker.ss            | 24 ++++++++++----------
 collects/handin-server/handin-server.ss      |  7 +++---
 collects/handin-server/private/run-status.ss | 11 +--------
 collects/handin-server/utils.ss              |  1 -
 4 files changed, 16 insertions(+), 27 deletions(-)

diff --git a/collects/handin-server/checker.ss b/collects/handin-server/checker.ss
index 52bbb58add..c89fa39648 100644
--- a/collects/handin-server/checker.ss
+++ b/collects/handin-server/checker.ss
@@ -328,16 +328,18 @@
   (let ([new (list line)] [cur (thread-cell-ref added-lines)])
     (if cur (append! cur new) (thread-cell-set! added-lines new))))
 
-(define (wrap-evaluator eval)
-  (lambda (expr)
-    (current-error-message-tweaker
-     (lambda (msg) (format "~a, while evaluating ~s" msg expr)))
-    (begin0 (eval expr)
-      ;; this will not happen if there was an error, so the above will still be
-      ;; in -- but the problem is that some evaluations may intentionally raise
-      ;; exception, so need to clear out this parameter anyway when done with
-      ;; testing.
-      (current-error-message-tweaker #f))))
+(define ((wrap-evaluator eval) expr)
+  (define (reraise exn)
+    (raise
+     (let-values ([(struct-type skipped?) (struct-info exn)])
+       (if (and struct-type (not skipped?))
+         (let ([vals (vector->list (struct->vector exn))])
+           (apply (struct-type-make-constructor struct-type)
+                  (string->immutable-string
+                   (format "while evaluating ~s:\n  ~a" expr (cadr vals)))
+                  (cddr vals)))
+         e))))
+  (with-handlers ([exn? reraise]) (eval expr)))
 
 (provide check:)
 (define-syntax (check: stx)
@@ -520,8 +522,6 @@
                                          (with-bindings eval bindings
                                            body*1 body* (... ...))])])
                           (let () body ...))
-                        ;; see the comment in `wrap-evaluator' for this:
-                        (current-error-message-tweaker #f)
                         ;; test coverage at the end (no harm if already done in
                         ;; the checker since it's cheap):
                         (when coverage? (!all-covered))
diff --git a/collects/handin-server/handin-server.ss b/collects/handin-server/handin-server.ss
index 11f4ad7580..3e32bc3b1b 100644
--- a/collects/handin-server/handin-server.ss
+++ b/collects/handin-server/handin-server.ss
@@ -631,10 +631,9 @@
               ;; Check protocol:
               (with-handlers ([exn:fail?
                                (lambda (exn)
-                                 (let ([msg (tweak-error-message
-                                             (if (exn? exn)
-                                               (exn-message exn)
-                                               (format "~e" exn)))])
+                                 (let ([msg (if (exn? exn)
+                                              (exn-message exn)
+                                              (format "~e" exn))])
                                    (kill-watcher)
                                    (log-line "ERROR: ~a" msg)
                                    (write+flush w msg)
diff --git a/collects/handin-server/private/run-status.ss b/collects/handin-server/private/run-status.ss
index cb5a98d85f..5a0aee0a33 100644
--- a/collects/handin-server/private/run-status.ss
+++ b/collects/handin-server/private/run-status.ss
@@ -1,8 +1,7 @@
 (module run-status mzscheme
 
   (provide current-run-status-box set-run-status
-           current-messenger message
-           current-error-message-tweaker tweak-error-message)
+           current-messenger message)
 
   ;; current-run-status-box is used to let the client know where we are in the
   ;; submission process.
@@ -19,12 +18,4 @@
     (let ([b (current-run-status-box)])
       (when b (set-box! b s) (message s))))
 
-  ;; current-error-message-tweaker is a function that is used to change an
-  ;; error message that is sent to the user.  Typical use is to add "while
-  ;; evaluating ..." to messages.
-  (define current-error-message-tweaker (make-parameter #f))
-  (define (tweak-error-message msg)
-    (let ([t (current-error-message-tweaker)])
-      (if t (t msg) msg)))
-
   )
diff --git a/collects/handin-server/utils.ss b/collects/handin-server/utils.ss
index 221d91b65b..ed6a5fd206 100644
--- a/collects/handin-server/utils.ss
+++ b/collects/handin-server/utils.ss
@@ -28,7 +28,6 @@
            set-run-status
            message
            current-value-printer
-           current-error-message-tweaker
 
            check-proc
            check-defined