diff --git a/collects/tests/framework/framework-test-engine.ss b/collects/tests/framework/framework-test-engine.ss index 36722492..9bae26a2 100644 --- a/collects/tests/framework/framework-test-engine.ss +++ b/collects/tests/framework/framework-test-engine.ss @@ -1,3 +1,5 @@ +(require-library "errortrace.ss" "errortrace") + (let* ([errs null] [sema (make-semaphore 1)] [protect @@ -6,10 +8,19 @@ (begin0 (f) (semaphore-post sema)))]) (thread - (let ([print-convert - (parameterize ([current-namespace (make-namespace)]) - (require-library "pconvert.ss") - (global-defined-value 'print-convert))]) + (let* ([print-convert + (parameterize ([current-namespace (make-namespace)]) + (require-library "pconvert.ss") + (global-defined-value 'print-convert))] + [exception->string + (lambda (x) + (if (exn? x) + (if (defined? 'errortrace-print-trace) + (let ([p (open-output-string)]) + (errortrace-print-trace p x) + (string-append (exn-message x) (string #\newline) (get-output-string p))) + (exn-message x)) + (format "~s" x)))]) (lambda () (let*-values ([(in out) (tcp-connect "localhost" (load-relative "receive-sexps-port.ss"))] [(continue) (make-semaphore 0)]) @@ -24,23 +35,16 @@ (write (let ([these-errs (protect (lambda () (begin0 errs (set! errs null))))]) (if (null? these-errs) - (with-handlers ([(lambda (x) #t) - (lambda (exn) - (list 'error (if (exn? exn) - (exn-message exn) - (format "~s" exn))))]) + (with-handlers ([(lambda (x) #t) + (lambda (x) (list 'error (exception->string x)))]) (list 'normal (print-convert (eval sexp)))) (list 'error (apply string-append - (map (lambda (x) - (string-append - (if (exn? x) (exn-message x) (format "~s" x)) - (string #\newline))) + (map (lambda (x) (string-append (exception->string x) (string #\newline))) these-errs))))) - out) (loop))))))))) - + (let ([od (event-dispatch-handler)] [port (current-output-port)]) (event-dispatch-handler diff --git a/collects/tests/framework/panel.ss b/collects/tests/framework/panel.ss new file mode 100644 index 00000000..4514185d --- /dev/null +++ b/collects/tests/framework/panel.ss @@ -0,0 +1,4 @@ +(test + 'single-panel + (lambda (x) (eq? x 'passed)) + `passed) diff --git a/collects/tests/framework/prefs.ss b/collects/tests/framework/prefs.ss index 30847106..573fec2d 100644 --- a/collects/tests/framework/prefs.ss +++ b/collects/tests/framework/prefs.ss @@ -41,7 +41,7 @@ (preferences:get ',pref-sym)))) -(test 'preference-dialog-appears +(test 'dialog-appears (lambda (x) (eq? 'passed x)) (lambda () (send-sexp-to-mred '(preferences:show-dialog))