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

removed the tweaker hack for a solution that creates a new exception

Browse Source 
svn: r5446
This commit is contained in:
Eli Barzilay 2007-01-24 07:52:51 +00:00
parent 4511f58d0c
commit 9673f7e703
4 changed files with 16 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
collects/handin-server/checker.ss
View File

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

7
collects/handin-server/handin-server.ss
View File

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

11
collects/handin-server/private/run-status.ss
View File

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

1
collects/handin-server/utils.ss
View File

@ -28,7 +28,6 @@
set-run-status
message
current-value-printer
current-error-message-tweaker
check-proc
check-defined