Decouple depnendce on mred

svn: r9208

collects/test-engine/scheme-tests.ss

@@ -6,8 +6,7 @@
          mzlib/pretty
          mzlib/pconvert
          mzlib/class
-         "scheme-gui.scm"
+         "scheme-gui.scm")
-         "test-display.scm")
 
 (require-for-syntax stepper/private/shared)
 
@@ -48,6 +47,8 @@
                                                    (current-namespace))])
           (and test-info
                (let ([display-data (scheme-test-data)])
+                 (send test-info refine-display-class 
+                       (dynamic-require '(lib "test-display.scm" "test-engine") 'test-display%))
                  (send test-info setup-display
                        (car display-data) (cadr display-data))
                  (send test-info summarize-results (current-output-port)))))
@@ -60,7 +61,6 @@
       #'(let ([test-info (namespace-variable-value 'test~object #f builder
                                                    (current-namespace))])
           (and test-info
-               (send test-info refine-display-class test-display-textual%)
                (send test-info summarize-results (current-output-port))))
       'test-call #t)]))
 

collects/test-engine/test-display.scm

@@ -282,97 +282,4 @@
                          (list (send parent get-percentages)))
         (send parent delete-child this)))))
 
-(define test-display-textual%
+(provide test-panel% test-window% test-display%)
-  (class* object% ()
-
-    (init-field (current-rep #f))
-
-    (define test-info #f)
-    (define/pubment (install-info t)
-      (set! test-info t)
-      (inner (void) install-info t))
-
-    (define/public (display-results)
-      (send this insert-test-results test-info))
-
-    (define/pubment (insert-test-results test-info)
-      (let* ([style (send test-info test-style)]
-             [total-tests (send test-info tests-run)]
-             [failed-tests (send test-info tests-failed)]
-             [total-checks (send test-info checks-run)]
-             [failed-checks (send test-info checks-failed)]
-             [test-outcomes
-              (lambda (zero-message)
-                (printf "~a"
-                        (cond [(zero? total-tests) zero-message]
-                              [(= 1 total-tests) "Ran 1 test.\n"]
-                              [else (format "Ran ~a tests.\n" total-tests)]))
-                (when (> total-tests 0)
-                  (printf "~a"
-                          (cond
-                            [(and (zero? failed-tests) (= 1 total-tests))
-                             "Test passed!\n\n"]
-                            [(zero? failed-tests) "All tests passed!\n\n"]
-                            [(= failed-tests total-tests) "0 tests passed.\n"]
-                            [else "~a of the ~a tests failed.\n\n"]))))]
-             [check-outcomes
-              (lambda (zero-message)
-                (printf "~a"
-                        (cond
-                          [(zero? total-checks) zero-message]
-                          [(= 1 total-checks) "Ran 1 check.\n"]
-                          [else (format "Ran ~a checks.\n" total-checks)]))
-                (when (> total-checks 0)
-                  (printf "~a"
-                          (cond
-                            [(and (zero? failed-checks) (= 1 total-checks))
-                             "Check passed!\n\n"]
-                            [(zero? failed-checks) "All checks passed!\n\n"]
-                            [(= failed-checks total-checks) "0 checks passed.\n"]
-                            [else (format "~a of the ~a checks failed.\n\n"
-                                          failed-checks total-checks)]))))])
-        (case style
-          [(test-require)
-           (test-outcomes "This program must be tested!\n")
-           (check-outcomes "This program is unchecked!\n")]
-          [(check-require)
-           (check-outcomes "This program is unchecked!\n")]
-          [(test-basic)
-           (test-outcomes "")
-           (check-outcomes "")]
-          [else (check-outcomes "")])
-
-        (unless (and (zero? total-checks) (zero? total-tests))
-          (inner (display-check-failures (send test-info failed-checks)
-                                         test-info)
-                 insert-test-results test-info))))
-
-    (define/public (display-check-failures checks test-info)
-      (for ([failed-check (reverse checks)])
-        (printf "~a" "\t")
-        (make-link (failed-check-msg failed-check)
-                   (failed-check-src failed-check))
-        (printf "~a" "\n")))
-
-    (define/public (next-line) (printf "~a" "\n\t"))
-
-    ;; make-link: (listof (U string snip%)) src -> void
-    (define (make-link msg dest)
-      (for-each printf msg)
-      (printf (format-src dest)))
-
-    (define (format-src src)
-      (let ([src-file car]
-            [src-line cadr]
-            [src-col caddr])
-        (string-append
-         (cond [(symbol? (src-file src)) " At "]
-               [(path? (src-file src))
-                (string-append " In " (path->string (src-file src)) " at ")]
-               [(is-a? (src-file src) editor<%>) " At "])
-         "line " (number->string (src-line src))
-         " column " (number->string (src-col src)))))
-
-      (super-instantiate ())))
-
-(provide test-panel% test-window% test-display% test-display-textual%)

collects/test-engine/test-engine.scm

@@ -1,15 +1,107 @@
 #lang scheme/base
 
 (require scheme/class
-         "test-info.scm"
+         "test-info.scm")
-         "test-display.scm")
+
+(define test-display-textual%
+  (class* object% ()
+
+    (init-field (current-rep #f))
+
+    (define test-info #f)
+    (define/pubment (install-info t)
+      (set! test-info t)
+      (inner (void) install-info t))
+
+    (define/public (display-results)
+      (send this insert-test-results test-info))
+
+    (define/pubment (insert-test-results test-info)
+      (let* ([style (send test-info test-style)]
+             [total-tests (send test-info tests-run)]
+             [failed-tests (send test-info tests-failed)]
+             [total-checks (send test-info checks-run)]
+             [failed-checks (send test-info checks-failed)]
+             [test-outcomes
+              (lambda (zero-message)
+                (printf "~a"
+                        (cond [(zero? total-tests) zero-message]
+                              [(= 1 total-tests) "Ran 1 test.\n"]
+                              [else (format "Ran ~a tests.\n" total-tests)]))
+                (when (> total-tests 0)
+                  (printf "~a"
+                          (cond
+                            [(and (zero? failed-tests) (= 1 total-tests))
+                             "Test passed!\n\n"]
+                            [(zero? failed-tests) "All tests passed!\n\n"]
+                            [(= failed-tests total-tests) "0 tests passed.\n"]
+                            [else "~a of the ~a tests failed.\n\n"]))))]
+             [check-outcomes
+              (lambda (zero-message)
+                (printf "~a"
+                        (cond
+                          [(zero? total-checks) zero-message]
+                          [(= 1 total-checks) "Ran 1 check.\n"]
+                          [else (format "Ran ~a checks.\n" total-checks)]))
+                (when (> total-checks 0)
+                  (printf "~a"
+                          (cond
+                            [(and (zero? failed-checks) (= 1 total-checks))
+                             "Check passed!\n\n"]
+                            [(zero? failed-checks) "All checks passed!\n\n"]
+                            [(= failed-checks total-checks) "0 checks passed.\n"]
+                            [else (format "~a of the ~a checks failed.\n\n"
+                                          failed-checks total-checks)]))))])
+        (case style
+          [(test-require)
+           (test-outcomes "This program must be tested!\n")
+           (check-outcomes "This program is unchecked!\n")]
+          [(check-require)
+           (check-outcomes "This program is unchecked!\n")]
+          [(test-basic)
+           (test-outcomes "")
+           (check-outcomes "")]
+          [else (check-outcomes "")])
+
+        (unless (and (zero? total-checks) (zero? total-tests))
+          (inner (display-check-failures (send test-info failed-checks)
+                                         test-info)
+                 insert-test-results test-info))))
+
+    (define/public (display-check-failures checks test-info)
+      (for ([failed-check (reverse checks)])
+        (printf "~a" "\t")
+        (make-link (failed-check-msg failed-check)
+                   (failed-check-src failed-check))
+        (printf "~a" "\n")))
+
+    (define/public (next-line) (printf "~a" "\n\t"))
+
+    ;; make-link: (listof (U string snip%)) src -> void
+    (define (make-link msg dest)
+      (for-each printf msg)
+      (printf (format-src dest)))
+
+    (define (format-src src)
+      (let ([src-file car]
+            [src-line cadr]
+            [src-col caddr])
+        (string-append
+         (cond [(symbol? (src-file src)) " At "]
+               [(path? (src-file src))
+                (string-append " In " (path->string (src-file src)) " at ")]
+               [else " At "])
+         "line " (number->string (src-line src))
+         " column " (number->string (src-col src)))))
+
+      (super-instantiate ())))
 
 (define test-engine%
   (class* object% ()
     (field [test-info #f]
            [test-display #f])
 
-    (define display-class test-display%)
+    (define display-class test-display-textual%)
     (define display-rep #f)
     (define display-event-space #f)
 
@@ -62,4 +154,4 @@
     (define/pubment (run-testcase testcase)
       (inner (void) run-testcase testcase))))
 
-(provide test-engine%)
+(provide test-engine% test-display-textual%)