Syncing up.

svn: r18249

collects/drscheme/private/debug.ss

@@ -612,7 +612,7 @@ profile todo:
     (let ([dis (if (exn? dis/exn)
                    (cms->srclocs (exn-continuation-marks dis/exn))
                    dis/exn)])
-    (show-backtrace-window/edition-pairs error-text dis (map (λ (x) #f) dis/exn) defs rep)))
+    (show-backtrace-window/edition-pairs error-text dis (map (λ (x) #f) dis) defs rep)))
   
   (define (show-backtrace-window/edition-pairs error-text dis editions defs ints)
     (reset-backtrace-window)

collects/drscheme/private/main.ss

@@ -561,6 +561,19 @@
                       (let ([frame (find-frame item)])
                         (when frame
                           (send frame next-tab))))])
+     (let ([frame (find-frame windows-menu)])
+       (unless (= 1 (send frame get-tab-count))
+         (for ([i (in-range 0 (send frame get-tab-count))]
+               #:when (< i 9))
+           (new menu-item% 
+                [parent windows-menu]
+                [label (format (string-constant tab-i)
+                               (+ i 1)
+                               (send frame get-tab-filename i))]
+                [shortcut (integer->char (+ (char->integer #\1) i))]
+                [callback
+                 (λ (a b)
+                   (send frame change-to-nth-tab i))]))))
      (new separator-menu-item% [parent windows-menu]))))
 
 ;; Check for any files lost last time.

collects/drscheme/private/unit.ss

@@ -2080,6 +2080,9 @@ module browser threading seems wrong.
             (unless (equal? label (send tabs-panel get-item-label (send tab get-i)))
               (send tabs-panel set-item-label (send tab get-i) label))))
         
+        (define/public (get-tab-filename i)
+          (get-defs-tab-filename (send (list-ref tabs i) get-defs)))
+        
         (define/private (get-defs-tab-label defs tab)
           (let ([fn (send defs get-filename)]
                 [i-prefix (or (for/or ([i (in-list tabs)]
@@ -2090,11 +2093,13 @@ module browser threading seems wrong.
                               "")])
             (string-append
              i-prefix
-             (add-modified-flag 
+             (get-defs-tab-filename defs))))
-              defs
+        
-              (if fn
+        (define/private (get-defs-tab-filename defs)
-                  (get-tab-label-from-filename fn)
+          (let ([fn (send defs get-filename)])
-                  (send defs get-filename/untitled-name))))))
+            (if fn
+                (get-tab-label-from-filename fn)
+                (send defs get-filename/untitled-name))))
         
         (define/private (get-tab-label-from-filename fn)
           (let* ([take-n

collects/schemeunit/gui.ss

@@ -0,0 +1,18 @@
+#lang scheme/base
+(require scheme/contract
+         (rename-in "private/base.ss")
+         "private/gui/gui.ss")
+
+(define (test/gui . tests)
+  (apply (make-gui-runner) tests))
+
+(define test/c (or/c schemeunit-test-case? schemeunit-test-suite?))
+
+(provide/contract
+ [test/gui
+  (->* () () #:rest (listof test/c)
+       any)]
+ [make-gui-runner
+  (->
+   (->* () () #:rest (listof test/c)
+        any))])

collects/schemeunit/info.ss

@@ -5,39 +5,9 @@
 (define blurb '((p "SchemeUnit is a unit testing framework based on the "
                    " Extreme Programming unit test frameworks")))
 
-(define repositories '("4.x"))
+(define scribblings '(("scribblings/schemeunit.scrbl" (multi-page) (tool))))
-(define required-core-version "4.0.0.0")
+(define tools '[("tool.ss")])
-(define categories '(devtools))
+(define tool-names '["SchemeUnit DrScheme integration"])
-(define can-be-loaded-with 'all)
 
 (define homepage "http://schematics.sourceforge.net/")
 (define url "http://schematics.sourceforge.net/")
-
-(define primary-file "main.ss")
-(define scribblings '(("scribblings/schemeunit.scrbl" (multi-page) (tool))))
-
-(define release-notes
-  '((p "Correctly handle arbitrary expressions in test suites and fix Scribble errors.")))
-
-;;
-;; The data below applies to the graphical UI.  It is kept
-;; around for when the GUI is ported to the current
-;; SchemeUnit
-;;
-
-;;  (define tools '[("drscheme-ui-tool.ss" "plt" "gui")])
-;;  (define tool-names '["SchemeUnit DrScheme integration"])
-  
-  ;; Information about SchemeUnit tests for package
-  
-;;  (define schemeunit:test-name 'all-schemeunit-tests)
-;;  (define schemeunit:test-module "all-schemeunit-tests.ss")
-
-  ;; Information about distribution
-  
-;;  (define distribution-method 'planet)
-;;  (define distribution-package-spec '("schematics" "schemeunit.plt" 3 0))
-
-
-
-

collects/schemeunit/main.ss

@@ -27,7 +27,5 @@
 ;; Commentary:
 
 #lang scheme/base
-
+(require "private/test.ss")
-(require "test.ss")
+(provide (all-from-out "private/test.ss"))
-
-(provide (all-from-out "test.ss"))

collects/schemeunit/private/check.ss

@@ -1,11 +1,9 @@
 #lang scheme/base
 
 (require (for-syntax scheme/base
-                     "location.ss"))
+                     "location.ss")
-
+         srfi/1
-(require srfi/1)
+         "base.ss"
-
-(require "base.ss"
          "check-info.ss"
          "format.ss"
          "location.ss")

collects/schemeunit/private/counter.ss

@@ -28,10 +28,9 @@
 
 #lang scheme/base
 
-(require
+(require "base.ss"
- (file "base.ss")
+         "monad.ss"
- (file "monad.ss")
+         "hash-monad.ss")
- (file "hash-monad.ss"))
 
 (provide display-counter
          update-counter!

collects/schemeunit/private/format.ss

@@ -1,20 +1,19 @@
 #lang scheme/base
 
 (require scheme/match
-         srfi/13)
+         srfi/13
+         "check-info.ss")
 
-(require "check-info.ss")
+(provide display-check-info-name-value
+         display-check-info
+         display-check-info-stack
+         display-test-name
+         display-exn
+
+         display-delimiter
+         display-failure
+         display-error)
 
-(provide
- display-check-info-name-value
- display-check-info
- display-check-info-stack
- display-test-name
- display-exn
- 
- display-delimiter
- display-failure
- display-error)
 ;; name-width : integer
 ;;
 ;; Number of characters we reserve for the check-info name column

collects/schemeunit/private/gui/cache-box.ss

@@ -0,0 +1,48 @@
+#lang scheme/base
+(require scheme/contract)
+
+;; Add a new kind of promise instead?
+
+;; FIXME: handle exceptions like promises?
+
+(define (make-cache* thunk)
+  (make-cache thunk #f))
+
+(define (cache-ref cb)
+  (let ([result (cache-result cb)])
+    (if result
+        (apply values result)
+        (call-with-values (cache-thunk cb)
+          (lambda result
+            (set-cache-result! cb result)
+            (apply values result))))))
+
+(define (cache-invalidate! cb)
+  (set-cache-result! cb #f))
+
+(define (cache-printer cb port write?)
+  (let ([result (cache-result cb)])
+    (if result
+        (fprintf port
+                 (if write? "#<cache!~s>" "#<cache!~a>")
+                 (if (and (pair? result) (null? (cdr result)))
+                     (car result)
+                     (cons 'values result)))
+        (fprintf port "#<cache>"))))
+
+(define-struct cache (thunk [result #:mutable])
+  #:property prop:custom-write cache-printer)
+
+(define-syntax-rule (cache* expr)
+  (make-cache* (lambda () expr)))
+
+(provide (rename-out [cache* cache]))
+(provide/contract
+ [rename make-cache* make-cache
+  (-> (-> any) cache?)]
+ [cache?
+  (-> any/c boolean?)]
+ [cache-ref
+  (-> cache? any)]
+ [cache-invalidate!
+  (-> cache? any)])

collects/schemeunit/private/gui/config.ss

@@ -0,0 +1,45 @@
+#lang scheme/base
+(require framework
+         unstable/gui/prefs)
+(provide (all-defined-out))
+
+;; Frame size preferences
+
+(preferences:set-default 'schemeunit:frame:width 400 exact-positive-integer?)
+(preferences:set-default 'schemeunit:frame:height 400 exact-positive-integer?)
+(define pref:width (pref:get/set 'schemeunit:frame:width))
+(define pref:height (pref:get/set 'schemeunit:frame:height))
+
+;; CONSTANTS
+;; Some of these are obsolete, given the preferences above.
+
+(define DETAILS-CANVAS-INIT-WIDTH 400)
+(define FRAME-LABEL "SchemeUnit")
+(define FRAME-INIT-HEIGHT 400)
+(define TREE-INIT-WIDTH 240)
+(define TREE-COLORIZE-CASES #t)
+(define DIALOG-ERROR-TITLE "SchemeUnit: Error")
+(define STATUS-SUCCESS 'success)
+(define STATUS-FAILURE 'failure)
+(define STATUS-ERROR 'error)
+(define STATUS-UNEXECUTED 'unexecuted)
+(define VIEW-PANE-PERCENTS 
+  (let [(total (+ DETAILS-CANVAS-INIT-WIDTH TREE-INIT-WIDTH))]
+    (list (/ TREE-INIT-WIDTH total) (/ DETAILS-CANVAS-INIT-WIDTH total))))
+
+;; Conventional assertion-info keys.
+;; These must be kept in sync with assert-base.ss.
+(define prop:failure-assertion 'name)
+(define prop:failure-parameters 'params)
+(define prop:failure-location 'location)
+(define prop:failure-message 'message)
+(define prop:test-case-location 'test-case-location)
+
+;; / CONSTANTS
+
+(define (known-property? s)
+  (case s
+    ((name params location message test-case-location) #t)
+    ((actual expected) #t)
+    ((expression) #t)
+    (else #f)))

collects/schemeunit/private/gui/controller.ss

@@ -0,0 +1,50 @@
+#lang scheme/base
+(require scheme/class
+         unstable/class-iop
+         unstable/gui/notify
+         "../base.ss"
+         "interfaces.ss"
+         "model.ss"
+         "view.ss")
+(provide controller%)
+
+(define controller%
+  (class* object% (controller<%>)
+    (init display-window)
+    (super-new)
+
+    ;; model-shown : (notify-box (U model<%> #f))
+    ;; The model currently displayed in the Details view, of #f is none.
+    (define-notify selected-model (new notify-box% (value #f)))
+
+    (define view
+      (new view%
+           (controller this)
+           (parent (send display-window get-area-container))))
+
+    ;; create-model : test suite<%>/#f -> result<%>
+    (define/public (create-model test parent)
+      (define result
+        (cond [(schemeunit-test-case? test)
+               (new case-result%
+                    (controller this)
+                    (test test)
+                    (name (or (schemeunit-test-case-name test)
+                              "<unnamed test-case>"))
+                    (parent parent))]
+              [(schemeunit-test-suite? test)
+               (new suite-result%
+                    (controller this)
+                    (test test)
+                    (name (or (schemeunit-test-suite-name test)
+                              "<unnamed test-suite>"))
+                    (parent parent))]))
+      (send/i view view<%> create-view-link result parent)
+      result)
+
+    ;; on-model-status-change : model<%> -> void
+    (define/public (on-model-status-change model)
+      (send view queue-for-update model)
+      (let [(parent (send model get-parent))]
+        (when parent (send parent on-child-status-change model))))
+    ))

collects/schemeunit/private/gui/drscheme-link.ss

@@ -0,0 +1,17 @@
+;; Written in #%kernel to avoid adding any module-attachment
+;; dependencies. Initialized by the DrScheme integration tool.
+
+(module drscheme-link '#%kernel
+  (#%provide link)
+
+  #|
+
+  If initialized (has non-#f value), the box should contain a vector
+  of the following procedures:
+  
+  (vector get-errortrace-backtrace
+          show-backtrace
+          show-source)
+  |#
+
+  (define-values (link) (box #f)))

collects/schemeunit/private/gui/drscheme-ui.ss

@@ -0,0 +1,97 @@
+#lang scheme/base
+(require scheme/list
+         scheme/string
+         mzlib/etc
+         "drscheme-link.ss")
+
+;; Procedures which *may* be overridden by DrScheme to do useful things.
+;; Or they may not be.
+
+(provide has-backtrace?
+         has-errortrace-backtrace?
+         has-primitive-backtrace?
+         show-errortrace-backtrace
+         show-primitive-backtrace
+         can-show-source?
+         show-source)
+
+;; A Backtrace is one of
+;;   - exn
+;;   - (listof srcloc)
+
+(define USE-PRIMITIVE-STACKTRACE? #f)
+
+;; has-backtrace? : exn -> boolean
+(define (has-backtrace? exn)
+  (or (has-errortrace-backtrace? exn)
+      (has-primitive-backtrace? exn)))
+
+;; has-errortrace-backtrace? : exn -> boolean
+(define (has-errortrace-backtrace? exn)
+  (not (null? (get-errortrace-backtrace exn))))
+
+;; has-primitive-backtrace? : exn -> boolean
+(define (has-primitive-backtrace? exn)
+  (and USE-PRIMITIVE-STACKTRACE?
+       (pair? (get-primitive-backtrace exn))))
+
+;; get-errortrace-backtrace : exn -> Backtrace
+(define (get-errortrace-backtrace exn)
+  ((get-errortrace-backtrace*) exn))
+
+;; get-primitive-backtrace : exn -> Backtrace
+(define (get-primitive-backtrace exn)
+  (let* ([ctx (continuation-mark-set->context
+               (exn-continuation-marks exn))]
+         [srclocs (map cdr ctx)])
+    (filter (lambda (s)
+              (and (srcloc? s)
+                   (let ([src (srcloc-source s)])
+                     (and (path? src)
+                          (not (regexp-match?
+                                (regexp-quote
+                                 (path->string
+                                  (this-expression-source-directory)))
+                                (path->string src)))))))
+            srclocs)))
+
+;; show-errortrace-backtrace : exn -> void
+(define (show-errortrace-backtrace exn)
+  ((show-backtrace*)
+   (exn-message exn)
+   (get-errortrace-backtrace exn)))
+
+;; show-primitive-backtrace : exn -> void
+(define (show-primitive-backtrace exn)
+  ((show-backtrace*)
+   (exn-message exn)
+   (get-primitive-backtrace exn)))
+
+;; can-show-source? : -> boolean
+(define (can-show-source?)
+  (can-show-source?*))
+
+;; show-source : source number number -> void
+(define (show-source src pos span)
+  ((show-source*) src pos span))
+
+;; ----
+
+(define (get-link n)
+  (let ([v (unbox link)])
+    (and (vector? v) (vector-ref v n))))
+
+(define (get-errortrace-backtrace*)
+  (or (get-link 0)
+      (lambda (exn) null)))
+
+(define (show-backtrace*)
+  (or (get-link 1)
+      void))
+
+(define (show-source*)
+  (or (get-link 2)
+      void))
+
+(define (can-show-source?*)
+  (vector? (unbox link)))

collects/schemeunit/private/gui/gui.ss

@@ -0,0 +1,150 @@
+#lang scheme/base
+(require scheme/class
+         unstable/class-iop
+         scheme/gui
+         "../base.ss"
+         "../result.ss"
+         "../check-info.ss"
+         "interfaces.ss"
+         "controller.ss"
+         "view.ss")
+(provide make-gui-runner)
+
+(define (make-gui-runner)
+  (define frame
+    (parameterize ((current-eventspace (make-eventspace)))
+      (make-view-frame)))
+  (define controller
+    (new controller%
+         (display-window frame)))
+  (lambda tests
+    (for ([test (in-list tests)])
+      (run test controller))))
+
+(define (run test controller)
+  ;; state = parent result<%>
+
+  (define (for-suite-entry suite name before after state)
+    (define model
+      (send/i controller controller<%> create-model suite state))
+    (before)
+    model)
+
+  (define (for-suite-exit suite name before after state kid-state)
+    (after)
+    (send/i kid-state suite<%> finish!)
+    state)
+
+  (define (for-case case name action state)
+    (define model
+      (send/i controller controller<%> create-model case state))
+    (run-case case model)
+    state)
+
+  (foldts for-suite-entry for-suite-exit for-case
+          #f test))
+
+;; From old suite-runner:
+#|
+(define/public (run)
+  (let ([custodian (make-custodian)]
+        [before (schemeunit-test-suite-before test)]
+        [after (schemeunit-test-suite-after test)])
+    (parameterize [(current-custodian custodian)]
+      (dynamic-wind
+        before
+        (lambda ()
+          (for-each (lambda (c) (send c run)) (get-children))
+          (custodian-shutdown-all custodian))
+        after)))
+  (on-child-status-change #f))
+|#
+
+;; ----
+
+(define (run-case test model)
+  (define primerr (current-error-port))
+  (define iport (open-input-string ""))
+  (define super-cust (current-custodian))
+  (define cust (make-custodian))
+  (define-values (oport errport get-output)
+    (make-output-ports))
+  (let-values ([(test-result timing)
+                (parameterize [(current-input-port iport)
+                               (current-output-port oport)
+                               (current-error-port errport)
+                               (current-custodian cust)]
+                  (run/time-test test))])
+    ;;(set! timing times)
+    (define trash
+      (map (lambda (x) (format "~s" x))
+           (custodian-managed-list cust super-cust)))
+    (cond [(test-success? test-result)
+           (send/i model case<%> update
+                   test-result
+                   (test-success-result test-result)
+                   null
+                   timing
+                   (get-output)
+                   trash)]
+          [(test-failure? test-result)
+           (let* ([exn (test-failure-result test-result)]
+                  [property-stack (exn:test:check-stack exn)])
+             (send/i model case<%> update
+                     test-result
+                     (test-failure-result test-result)
+                     (for/list ([pp property-stack])
+                       (cons (check-info-name pp) (check-info-value pp)))
+                     timing
+                     (get-output)
+                     trash))]
+          [(test-error? test-result)
+           (send/i model case<%> update
+                   test-result
+                   (test-error-result test-result)
+                   null
+                   timing
+                   (get-output)
+                   trash)])))
+
+(define (run/time-test test)
+  (let-values ([(results cputime realtime gctime)
+                (call-with-continuation-prompt
+                 (lambda ()
+                   (time-apply run-test-case 
+                               (list (schemeunit-test-case-name test)
+                                     (schemeunit-test-case-action test)))))])
+    (values (car results) (list cputime realtime gctime))))
+
+(define (make-output-ports)
+  (define output null)
+  (define output-sema (make-semaphore 1))
+  (define (make-output-collector tag)
+    (define (do-write-out buf start end)
+      (define subbuf (subbytes buf start end))
+      (if (and (pair? output)
+               (eq? (car (car output)) tag))
+          ;; Coalesce
+          (let ([prev (cdr (car output))])
+            (set! output
+                  (cons (cons tag (cons subbuf prev)) (cdr output))))
+          (set! output (cons (list tag subbuf) output)))
+      (- end start))
+    (define name #f)
+    (define evt output-sema)
+    (define (write-out buf start end buffer? enable-break?)
+      ((if enable-break? sync/enable-break sync) output-sema)
+      (begin0 (do-write-out buf start end) (semaphore-post output-sema)))
+    (define (close) (void))
+    (define (get-write-evt buf start end)
+      (wrap-evt output-sema
+                (lambda (_)
+                  (begin0 (write-out buf start end #f #f)
+                    (semaphore-post output-sema)))))
+    (make-output-port name evt write-out close #f
+                      get-write-evt #f))
+  (values (make-output-collector 'output)
+          (make-output-collector 'error)
+          (lambda () output)))
+  
+

collects/schemeunit/private/gui/gvector.ss

@@ -0,0 +1,111 @@
+#lang scheme/base
+(require scheme/contract
+         scheme/dict)
+
+(define (make-gvector* #:capacity [capacity 10])
+  (make-gvector (make-vector capacity #f) 0))
+
+(define (check-index who index n)
+  (unless (exact-nonnegative-integer? index)
+    (raise-type-error who "exact nonnegative integer" index))
+  (unless (< index n)
+    (if (zero? n)
+        (error who "index out of range for empty gvector: ~s" index)
+        (error who "index out of range [0,~s]: ~s" (sub1 n) index))))
+
+(define ((bad-index-error who index))
+  (raise-mismatch-error who "index out of range" index))
+
+(define (gvector-add! gv item)
+  (let ([n (gvector-n gv)]
+        [v (gvector-vec gv)])
+    (cond [(< n (vector-length v))
+           (vector-set! v n item)
+           (set-gvector-n! gv (add1 n))]
+          [else
+           (let ([nv (make-vector (* 2 n) #f)])
+             (vector-copy! nv 0 v)
+             (vector-set! nv n item)
+             (set-gvector-vec! gv nv)
+             (set-gvector-n! gv (add1 n)))])))
+
+;; SLOW!
+(define (gvector-remove! gv index)
+  (let ([n (gvector-n gv)]
+        [v (gvector-vec gv)])
+    (check-index 'gvector-remove! index n)
+    (set-gvector-n! gv (sub1 n))
+    (vector-copy! v index v (add1 index) n)
+    (vector-set! v (sub1 n) #f)))
+
+(define (gvector-count gv)
+  (gvector-n gv))
+
+(define (gvector-ref gv index
+                     [default (bad-index-error 'gvector-ref index)])
+  (unless (exact-nonnegative-integer? index)
+    (raise-type-error 'gvector-ref "exact nonnegative integer" index))
+  (if (< index (gvector-n gv))
+      (vector-ref (gvector-vec gv) index)
+      (if (procedure? default)
+          (default)
+          default)))
+
+(define (gvector-set! gv index item)
+  (check-index 'gvector-set! index (gvector-n gv))
+  (vector-set! (gvector-vec gv) index item))
+
+;; Iteration methods
+
+(define (gvector-iterate-first gv)
+  (and (positive? (gvector-n gv)) 0))
+
+(define (gvector-iterate-next gv iter)
+  (check-index 'gvector-iterate-next iter (gvector-n gv))
+  (let ([n (gvector-n gv)])
+    (and (< (add1 iter) n)
+         (add1 iter))))
+
+(define (gvector-iterate-key gv iter)
+  (check-index 'gvector-iterate-key iter (gvector-n gv))
+  iter)
+
+(define (gvector-iterate-value gv iter)
+  (check-index 'gvector-iterate-value iter (gvector-n gv))
+  (gvector-ref gv iter))
+
+(define (in-gvector gv)
+  (unless (gvector? gv)
+    (raise-type-error 'in-gvector "gvector" gv))
+  (in-dict-values gv))
+
+(define-struct gvector (vec n)
+  #:mutable
+  #:property prop:dict
+             (vector gvector-ref
+                     gvector-set!
+                     #f ;; set
+                     gvector-remove!
+                     #f ;; remove
+                     gvector-count
+                     gvector-iterate-first
+                     gvector-iterate-next
+                     gvector-iterate-key
+                     gvector-iterate-value)
+  #:property prop:sequence in-gvector)
+
+(provide/contract
+ [rename make-gvector* make-gvector
+  (->* () (#:capacity exact-positive-integer?) any)]
+ [gvector-ref
+  (-> gvector? exact-nonnegative-integer? any)]
+ [gvector-set!
+  (-> gvector? exact-nonnegative-integer? any/c any)]
+ [gvector-add!
+  (-> gvector? any/c any)]
+ [gvector-remove!
+  (-> gvector? exact-nonnegative-integer? any)]
+ [gvector-count
+  (-> gvector? any)]
+ [in-gvector
+  (-> gvector? sequence?)])

collects/schemeunit/private/gui/interfaces.ss

@@ -0,0 +1,63 @@
+#lang scheme/base
+(require scheme/class
+         unstable/class-iop)
+(provide (all-defined-out))
+
+;; controller
+;; Manages the model and view.
+;; Propagates status changes from model to view.
+(define-interface controller<%> ()
+  (get-selected-model
+   set-selected-model
+   listen-selected-model
+
+   create-model
+   on-model-status-change))
+
+;; result
+;; Represents a test (case or suite) together with the state associated
+;; with the last run of that test.
+(define-interface result<%> ()
+  (get-test
+   get-parent
+   get-name
+   get-controller
+
+   finished?
+   success?
+   failure?
+   error?
+   has-output?
+   has-trash?
+
+   get-total-cases
+   get-total-successes
+   get-total-failures))
+
+(define-interface case<%> (result<%>)
+  (update
+   get-result
+   get-timing
+   get-output
+   get-trash
+   get-property
+   get-property-set
+   get-all-properties))
+
+(define-interface suite<%> (result<%>)
+  (get-children
+   add-child
+   finish!
+   on-child-status-change))
+
+
+;; view
+;; Presents a graphical interface for inspecting and running tests.
+(define-interface view<%> ()
+  (create-view-link
+   queue-for-update))
+
+;; style-map
+;; Maps symbolic style names ('bold, 'red) to MrEd styles.
+(define-interface style-map<%> ()
+  (get-style))

collects/schemeunit/private/gui/model.ss

@@ -0,0 +1,148 @@
+#lang scheme/base
+(require scheme/class
+         unstable/class-iop
+         scheme/list
+         "gvector.ss"
+         "../base.ss"
+         "interfaces.ss"
+         "cache-box.ss")
+(provide case-result%
+         suite-result%)
+
+(define result%
+  (class* object% ()
+    (super-new)
+
+    (init-field parent
+                controller
+                name
+                test)
+
+    (when parent
+      (send/i parent suite<%> add-child this))
+
+    (define/public (get-parent) parent)
+    (define/public (get-name) name)
+    (define/public (get-controller) controller)
+    (define/public (get-test) test)
+    ))
+
+;; case-result%
+(define case-result%
+  (class* result% (case<%>)
+    (super-new)
+
+    (inherit get-name
+             get-parent
+             get-controller)
+
+    ;; *result : #f or test-result
+    ;; #f means not finished executing
+    (define *result #f)
+
+    (define result #f)
+    (define properties #f)
+    (define timing #f)
+    (define output null)
+    (define trash null)
+
+    (define/public (update *result* result* properties* timing* output* trash*)
+      (set! *result *result*)
+      (set! result result*)
+      (set! properties properties*)
+      (set! timing timing*)
+      (set! output output*)
+      (set! trash trash*)
+      (send/i (get-controller) controller<%> on-model-status-change this))
+
+    (define/public (finished?) (and *result #t))
+    (define/public (success?) (test-success? *result))
+    (define/public (failure?) (test-failure? *result))
+    (define/public (error?) (test-error? *result))
+
+    (define/public (get-total-cases) 1)
+    (define/public (get-total-successes)
+      (if (success?) 1 0))
+    (define/public (get-total-failures)
+      (if (or (failure?) (error?)) 1 0))
+
+    (define/public (get-result) result)
+    (define/public (get-timing) timing)
+    (define/public (get-trash) trash)
+    (define/public (has-trash?) (pair? trash))
+    (define/public (get-property p)
+      (let [(v (assq p properties))]
+        (and v (cdr v))))
+    (define/public (get-property-set p)
+      (map cdr (filter (lambda (kv) (eq? (car kv) p)) properties)))
+    (define/public (get-all-properties)
+      properties)
+
+    (define/public (get-output) (reverse output))
+    (define/public (has-output?) (pair? output))))
+
+
+;; suite-result%
+(define suite-result%
+  (class* result% (suite<%>)
+    (super-new)
+    (inherit get-name
+             get-parent
+             get-controller)
+
+    (define done? #f)
+    (define children (make-gvector))
+
+    ;; get-children : -> (listof result<%>)
+    (define/public (get-children)
+      (for/list ([x (in-gvector children)]) x))
+
+    (define/public (add-child c)
+      (gvector-add! children c))
+
+    (define/public (finish!)
+      (set! done? #t)
+      (send/i (get-controller) controller<%> on-model-status-change this))
+
+    (define children-cache
+      (cache (for/fold ([cs 0] [ss 0] [fs 0] [out? #f] [trash? #f])
+                 ([c (in-gvector children)])
+               (values (+ cs (send/i c result<%> get-total-cases))
+                       (+ ss (send/i c result<%> get-total-successes))
+                       (+ fs (send/i c result<%> get-total-failures))
+                       (or out? (send/i c result<%> has-output?))
+                       (or trash? (send/i c result<%> has-trash?))))))
+
+    (define/public (finished?)
+      done?)
+    (define/public (get-total-cases)
+      (define-values (c _s _f _o _t) (cache-ref children-cache))
+      c)
+    (define/public (get-total-successes)
+      (define-values (_c s _f _o _t) (cache-ref children-cache))
+      s)
+    (define/public (get-total-failures)
+      (define-values (_c _s f _o _t) (cache-ref children-cache))
+      f)
+    (define/public (has-output?)
+      (define-values (_c _s _f o _t) (cache-ref children-cache))
+      o)
+    (define/public (has-trash?)
+      (define-values (_c _s _f _o t) (cache-ref children-cache))
+      t)
+
+    (define/public (success?)
+      (and (finished?) (zero? (get-total-failures))))
+    (define/public (failure?)
+      (positive? (get-total-failures)))
+    (define/public (error?) #f)
+
+    ;; on-child-status-change : model<%> -> void
+    (define/public (on-child-status-change child)
+      (let ([result
+             (call-with-values (lambda () (cache-ref children-cache)) list)])
+        (cache-invalidate! children-cache)
+        (let ([new-result
+               (call-with-values (lambda () (cache-ref children-cache)) list)])
+          (unless (equal? new-result result)
+            (send/i (get-controller) controller<%> on-model-status-change this)))))))

collects/schemeunit/private/gui/model2rml.ss

@@ -0,0 +1,458 @@
+#lang scheme/base
+(require scheme/class
+         unstable/class-iop
+         scheme/list
+         scheme/gui
+         scheme/match
+         scheme/file
+         mrlib/include-bitmap
+         (prefix-in drlink: "drscheme-ui.ss")
+         "interfaces.ss"
+         "config.ss")
+(provide model-renderer%
+         output-icon)
+
+(define (output-icon)
+  (make-object image-snip% (include-bitmap "output-icon.png")))
+
+(define top-align (make-object style-delta% 'change-alignment 'top))
+
+(define model-renderer%
+  (class object%
+    (init-field controller)
+    (init-field editor)
+    (super-new)
+
+    (define/public (render-model/short model)
+      (cond [(is-a? model suite<%>) ;; (test-suite? test)
+             (render-suite-short-form model)]
+            [(is-a? model case<%>) ;; (test-case? test)
+             (render-case-short-form model)]))
+
+    (define/public (render-model/long model)
+      (cond [(is-a? model suite<%>) ;; (test-suite? test)
+             (render-suite-long-form model)]
+            [(is-a? model case<%>) ;; (test-case? test)
+             (render-case-long-form model)]))
+
+    (define/private (put styles . texts)
+      (send/apply editor insert/styles styles texts))
+
+    (define/private (put+click styles clickback . texts)
+      (send/apply editor insert/styles+click styles clickback texts))
+
+    (define/private (blank)
+      (send editor newline))
+
+    (define/private (n-things number singular plural)
+      (if (= 1 number)
+          (format "~a ~a" number singular)
+          (format "~a ~a" number plural)))
+    
+    (define/private (render-suite-long-form model)
+      (let [(suite (send/i model suite<%> get-test))
+            (children (send/i model suite<%> get-children))
+            (parent (send/i model suite<%> get-parent))]
+        (let* [(successes
+                (filter (lambda (c) (send/i c result<%> success?)) children))
+               (failures
+                (filter (lambda (c) (send/i c result<%> failure?)) children))
+               (errors
+                (filter (lambda (c) (send/i c result<%> error?)) children))
+               (unexecuted
+                (filter (lambda (c) (not (send/i c result<%> finished?))) children))
+               (finished? (send/i model suite<%> finished?))
+               (num-tests (length children))
+               (count-successes (length successes))
+               (count-failures (length failures))
+               (count-errors (length errors))
+               (count-unexecuted (length unexecuted))
+               (total-successes (send/i model suite<%> get-total-successes))
+               (total-failures (send/i model suite<%> get-total-failures))
+               (total-cases (send/i model suite<%> get-total-cases))
+               (output? (send/i model suite<%> has-output?))
+               (trash? (send/i model suite<%> has-trash?))]
+          (put '(large italic bold) (send/i model suite<%> get-name) "\n")
+          (when parent
+            (put '() " (in ")
+            (put+click '(clickback bold)
+                       (lambda _ (send/i controller controller<%> set-selected-model parent))
+                       (send/i parent result<%> get-name))
+            (put '() ")\n"))
+          (blank)
+          (if (positive? total-cases)
+              (begin (put '() (format "Total: ~a"
+                                      (n-things total-successes "success" "successes")))
+                     (when (positive? total-failures)
+                       (put '() (format ", ~a"
+                                        (n-things total-failures "failure" "failures"))))
+                     (blank)
+                     (blank)
+                     (when trash?
+                       (put (list top-align) (output-icon))
+                       (put '() "Tests did not clean up resources.\n"))
+                     (when output?
+                       (put (list top-align) (output-icon))
+                       (put '() "Tests produced output.\n"))
+                     (when (or trash? output?)
+                       (blank))
+                     (when (positive? count-failures)
+                       (put '(large)
+                            (format "Failures (~a/~a)\n"
+                                    count-failures
+                                    num-tests))
+                       (for-each (lambda (m) (render-model/short m)) failures)
+                       (blank))
+                     (when (positive? count-errors)
+                       (put '(large)
+                            (format "Errors (~a/~a)\n"
+                                    count-errors
+                                    num-tests))
+                       (for-each (lambda (m) (render-model/short m)) errors)
+                       (blank))
+                     (when (positive? count-unexecuted)
+                       (put '(large)
+                            (format "Unexecuted (~a/~a)\n"
+                                    (length unexecuted)
+                                    num-tests))
+                       (for-each (lambda (m) (render-model/short m)) unexecuted)
+                       (blank))
+                     (when (positive? count-successes)
+                       (put '(large)
+                            (format "Successes (~a/~a)\n"
+                                    count-successes
+                                    num-tests))
+                       (for-each (lambda (m) (render-model/short m)) successes)
+                       (blank)))
+              (if finished?
+                  (put '()
+                       "This test suite is empty.")
+                  (put '(test-unexecuted)
+                       "This test suite has not been executed."))))))
+
+    (define/private (render-model-link model suite?)
+      (let ([styles (if suite? '(clickback bold) '(clickback))])
+        (put+click styles
+                   (lambda _ (send/i controller controller<%> set-selected-model model))
+                   (send/i model result<%> get-name))
+        (when (or (send/i model result<%> has-output?)
+                  (send/i model result<%> has-trash?))
+          (put styles (output-icon)))))
+
+    (define/private (render-suite-short-form model)
+      (let [(suite (send/i model suite<%> get-test))]
+        (let* [(children (send/i model suite<%> get-children))
+               (successes
+                (filter (lambda (c) (send/i c result<%> success?)) children))
+               (failures
+                (filter (lambda (c) (send/i c result<%> failure?)) children))
+               (errors
+                (filter (lambda (c) (send/i c result<%> error?)) children))
+               (unexecuted
+                (filter (lambda (c) (not (send/i c result<%> finished?))) children))
+               (num-tests (length children))
+               (total-failures (send/i model suite<%> get-total-failures))]
+          (let [(style (if (and (null? failures) (null? errors)) 'normal 'red))]
+            (render-model-link model #t)
+            (if (send/i model suite<%> finished?)
+                (when (positive? total-failures)
+                  (put `(,style)
+                       (format " (~a)"
+                               (n-things total-failures "failure" "failures"))))
+                (put '(test-unexecuted) " not yet executed"))
+            (blank)))))
+
+    (define/private (render-case-short-form model)
+      (cond [(send/i model case<%> success?)
+             (render-success-short-form model)]
+            [(send/i model case<%> failure?)
+             (render-failure-short-form model)]
+            [(send/i model case<%> error?)
+             (render-error-short-form model)]
+            [(not (send/i model case<%> finished?))
+             (render-not-executed-short-form model)]))
+
+    (define/private (render-success-short-form model)
+      (render-model-link model #f)
+      (put '() " succeeded\n"))
+
+    (define/private (render-failure-short-form model)
+      (let* [(exn (send/i model case<%> get-result))
+             (exnmsg (send/i model case<%> get-property prop:failure-message))
+             (exnname (send/i model case<%> get-property prop:failure-assertion))]
+        (render-model-link model #f)
+        (put '() " failed")
+        (when exnname
+          (put '() " on ")
+          (put '(fail-type) (format "~a" exnname)))
+        (when exnmsg
+          (put '() " with message: ")
+          (put '(exn-message) exnmsg))
+        (blank)))
+
+    (define/private (render-error-short-form model)
+      (let [(exn (send/i model case<%> get-result))]
+        (render-model-link model #f)
+        (cond [(exn? exn)
+               (put '() " threw an exception of type ")
+               (put '(exn-type) (format "~a" (object-name exn)))
+               (put '() " with message: ")
+               (put '(exn-message) (exn-message exn))]
+              [else
+               (put '() (format " raised the value ~e" exn))])
+        (blank)))
+
+    (define/private (render-not-executed-short-form model)
+      (render-model-link model #f)
+      (put '(test-unexecuted) " has not been executed\n"))
+
+    (define/private (render-case-long-form model)
+      (cond [(send/i model case<%> success?)
+             (render-success-long-form model)]
+            [(send/i model case<%> failure?)
+             (render-failure-long-form model)]
+            [(send/i model case<%> error?)
+             (render-error-long-form model)]
+            [(not (send/i model case<%> finished?))
+             (render-not-executed-long-form model)])
+      (when (send/i model case<%> finished?)
+        (render-timing model)
+        (render-trash model)
+        (render-output model)))
+
+    (define/private (render-model-link* model suite?)
+      (let [(parent (send/i model result<%> get-parent))]
+        (let ([styles (if suite? '(bold) '())])
+          (put `(large italic ,@styles)
+               (send/i model result<%> get-name))
+          (blank)
+          (when parent
+            (put '() "  in ")
+            (put+click `(clickback bold)
+                       (lambda _ (send/i controller controller<%> set-selected-model parent))
+                       (send/i parent result<%> get-name))
+            (blank))
+          (blank))))
+
+    (define/private (render-success-long-form model)
+      (render-model-link* model #f)
+      (put '() "The test case succeeded.\n\n"))
+
+    (define/private (render-failure-long-form model)
+      (render-model-link* model #f)
+      (let* [(exn (send/i model case<%> get-result))
+             (failure-msgs (send/i model case<%> get-property-set prop:failure-message))
+             (messages
+              (if (string? (exn-message exn))
+                  (cons (exn-message exn) failure-msgs)
+                  failure-msgs))
+             (exnname (send/i model case<%> get-property prop:failure-assertion))
+             (exnlocs
+              (send/i model case<%> get-property-set prop:failure-location))
+             (expecteds (send/i model case<%> get-property-set 'expected))
+             (actuals (send/i model case<%> get-property-set 'actual))
+             (params (send/i model case<%> get-property prop:failure-parameters))
+             (other-properties
+              (filter (lambda (p) (not (known-property? (car p))))
+                      (send/i model case<%> get-all-properties)))
+             (exn2 (send/i model case<%> get-property 'exception))]
+        (put '() "The test case failed on ")
+        (put '(fail-type) (format "~a" exnname))
+        (put '() ".\n\n")
+        (render-source-location "Check location" exnlocs)
+        (render-backtrace-link "Backtrace of check failure:" exn)
+        (render-messages messages)
+        (if (and (pair? expecteds) (pair? actuals))
+            (render-expected+actual (car expecteds) (car actuals))
+            (render-parameters params))
+        (render-embedded-exception exn2)
+        (render-other-properties other-properties)
+        ))
+    
+    (define/private (render-error-long-form model)
+      (render-model-link* model #f)
+      (let [(exn (send/i model case<%> get-result))]
+        (cond [(exn? exn)
+               (put '() "The test case threw an exception of type ")
+               (put '(exn-type) (format "~a" (object-name exn)))
+               (put '() ".\n\n")
+               (render-backtrace-link "Exception backtrace:" exn)
+               (render-messages (list (exn-message exn)))
+               (render-value "Exception value:\n" exn)]
+              [else
+               (put '() "The test raised a value that was not "
+                    "an instance of an exception struct.\n\n")
+               (render-value "Raised value:\n" exn)])))
+
+    (define/private (render-not-executed-long-form model)
+      (render-model-link* model #f)
+      (put '(test-unexecuted)
+           "The test case has not been executed."))
+
+    (define/private (render-value text value)
+      (put '() text)
+      (render-value-box value)
+      (blank))
+
+    (define/private (render-value-box value)
+      (send editor insert-wide-box
+            (lambda (editor)
+              (send editor insert/styles '(value) (format "~v" value)))))
+
+    (define/private (render-value-box/display value)
+      (send editor insert-wide-box
+            (lambda (editor)
+              (send editor insert/styles '(value) (format "~a" value)))))
+
+    (define/private (render-messages messages)
+      (when (pair? messages)
+        (put '() "Message:\n")
+        (for-each
+         (lambda (message)
+           (send editor insert-wide-box
+                 (lambda (editor)
+                   (send editor insert/styles '(exn-message) message))))
+         messages)
+        (blank)))
+
+    (define/private (render-expected+actual expected actual)
+      (put '() "Actual:\n")
+      (render-value-box actual)
+      (put '() "Expected:\n")
+      (render-value-box expected)
+      (blank))
+    
+    (define/private (render-parameters parameters)
+      (when (and parameters (pair? parameters))
+        (put '() "Parameters:\n")
+        (for-each (lambda (parameter) (render-value-box parameter))
+                  parameters)
+        (blank)))
+
+    (define/private (render-other-properties properties)
+      (when (pair? properties)
+        (put '() "Additional information:\n")
+        (for-each (lambda (p) (render-other-property (car p) (cdr p)))
+                  properties)
+        (blank)))
+
+    (define/private (render-other-property key value)
+      (put '() (format "key ~s:" key))
+      (when (exn? value)
+        (inline-backtrace-link "" value))
+      (put '() "\n")
+      (render-value-box value))
+
+    (define/private (render-embedded-exception exn)
+      (when (exn? exn)
+        (put '() "Received exception")
+        (inline-backtrace-link "" exn)
+        (put '() ":\n")
+        (render-value-box exn)
+        (blank)))
+
+    (define/private (render-source-location label location-reps)
+      (when (pair? location-reps)
+        (let* ([location-reps (reverse location-reps)]
+               [rep0 (car location-reps)]
+               [reps (cdr location-reps)])
+          (put '() label ": ")
+          (inline-source-location/1 rep0)
+          (blank)
+          (when (pair? reps)
+            (put '() "Inner locations: ")
+            (for-each (lambda (r) (inline-source-location/1 r)) reps)
+            (blank))
+          (blank)))
+      (unless (pair? location-reps)
+        (put '() label " is not available.")
+        (blank)
+        (blank)))
+
+    (define/private (inline-source-location/1 location)
+      (match location
+        [(list src line col pos span)
+         (let* ([file-name (resolve-source-file src)]
+                [short-file-name
+                 (if (or (path? file-name) (string? file-name))
+                     (path->string (file-name-from-path file-name))
+                     file-name)]
+                [source-location (format "~a:~a:~a" short-file-name line col)])
+           (inline-source-location/h source-location src pos span))]
+        [_ (put '() "not usable")]))
+
+    (define/private (inline-source-location/h source-location src pos span)
+      (if (and src (drlink:can-show-source?))
+          (put+click '(clickback)
+                     (lambda _ (drlink:show-source src pos span))
+                     source-location)
+          (put '() source-location)))
+
+    (define/private (render-backtrace-link text exn)
+      (when (exn? exn)
+        (if (drlink:has-backtrace? exn)
+            (inline-backtrace-link text exn)
+            (begin (put '() text)
+                   (put '() " not available")))
+        (blank)
+        (blank)))
+
+    (define/private (inline-backtrace-link text exn)
+      (when (drlink:has-backtrace? exn)
+        (put '() text))
+      (when (drlink:has-errortrace-backtrace? exn)
+        (put '() " ")
+        (put+click '(clickback)
+                   (lambda _ (drlink:show-errortrace-backtrace exn))
+                   "[from DrScheme]"))
+      (when (drlink:has-primitive-backtrace? exn)
+        (put '() " ")
+        (put+click '(clickback)
+                   (lambda _ (drlink:show-primitive-backtrace exn))
+                   "[from mzscheme]")))
+
+    (define/private (render-output model)
+      (let [(output (send/i model case<%> get-output))]
+        (when (pair? output)
+          (put '() "Output:\n")
+          (send editor insert-wide-box
+                (lambda (editor)
+                  (for ([mode+text output])
+                    (let ([styles
+                           (if (eq? (car mode+text) 'error)
+                               '(red italic)
+                               '(darkblue))]
+                          [buf (apply bytes-append
+                                      (reverse (cdr mode+text)))])
+                      (send editor insert/styles styles
+                            (bytes->string/utf-8 buf #\?))))))
+          (blank))))
+
+    (define/private (render-timing model)
+      (let [(timing (send/i model case<%> get-timing))]
+        (when timing
+          (let ([cpu (car timing)]
+                [real (cadr timing)]
+                [gc (caddr timing)])
+            (put '() "Timing:\n")
+            (put '() (format "cpu: ~a; real: ~a; gc: ~a\n\n"
+                             cpu real gc))))))
+
+    (define/private (render-trash model)
+      (let ([trash (send/i model case<%> get-trash)])
+        (when (pair? trash)
+          (put '() "Test did not clean up resources:\n")
+          (for-each (lambda (t) (render-value-box/display t)) trash)
+          (blank))))
+
+    (define/private (resolve-source-file src)
+      (or (and (is-a? src editor<%>)
+               (let* [(tmp?-box (box #t))
+                      (filename (send src get-filename tmp?-box))]
+                 (if (and filename (not (unbox tmp?-box)))
+                     filename
+                     #f)))
+          (cond [(path? src) (path->string src)]
+                [(string? src) src]
+                [else 'unknown])))
+    ))

collects/schemeunit/private/gui/rml.ss

@@ -0,0 +1,187 @@
+#lang scheme/base
+(require scheme/class
+         unstable/class-iop
+         scheme/gui
+         framework
+         "interfaces.ss")
+
+(provide insert-text
+         ext:text%
+         schemeunit-style-map)
+
+;; insert-text : text% string style-delta% -> void
+(define (insert-text e text style)
+  (let ([a (send e last-position)])
+    (send e insert text)
+    (let ([b (send e last-position)])
+      (send e change-style style a b))))
+
+(define text<%> (class->interface text%))
+
+(define ext:text-mixin
+  (mixin (text<%>) ()
+    (init-field (style-map schemeunit-style-map))
+    (inherit last-position
+             change-style
+             set-clickback
+             insert
+             get-canvas
+             set-styles-sticky
+             set-autowrap-bitmap)
+
+    (super-new (auto-wrap #t))
+    (set-styles-sticky #f)
+    (set-autowrap-bitmap #f)
+
+    ;; insert/styles : (list-of style-delta%) string ... -> void
+    ;; A list of styles to be applied. The first style is the last applied.
+    (define/public (insert/styles styles . texts)
+      (unless (andmap (lambda (x) (or (string? x) (is-a? x snip%))) texts)
+        (raise-type-error 'insert/styles "list of strings" texts))
+      (let-values ([(a b) (put texts)])
+        (for-each (lambda (style) (change-style (resolve style) a b))
+                  (reverse styles))))
+
+    ;; insert/styles+click : (list-of style-delta%) (?? -> void) string ...-> void
+    (define/public (insert/styles+click styles clickback . texts)
+      (unless (andmap (lambda (x) (or (string? x) (is-a? x snip%))) texts)
+        (raise-type-error 'insert/styles+click "list of strings" texts))
+      (let-values ([(a b) (put texts)])
+        (for-each (lambda (style) (change-style (resolve style) a b))
+                  (reverse styles))
+        (set-clickback a b clickback)))
+
+    ;; put : (list-of string) -> int int
+    (define/private (put texts)
+      (let ([a (last-position)])
+        (let loop ([texts texts] [where a])
+          (if (pair? texts)
+              (begin (insert (car texts) where 'same #f)
+                     (loop (cdr texts) (last-position)))
+              (values a where)))))
+
+    (define/private (resolve style)
+      (if (symbol? style)
+          (send style-map get-style style)
+          style))
+
+    ;; newline : -> void
+    (define/public (newline)
+      (insert/styles '() "\n"))
+
+    ;; insert-wide-box : (ext:text<%> -> void) -> void
+    (define/public (insert-wide-box p)
+      (internal-insert-box p #t)
+      (newline))
+
+    ;; internal-insert-box : (ext:text<%> -> void) boolean? -> void
+    (define/private (internal-insert-box p wide?)
+      (let* ([seditor (new ext:text%)]
+             [snip (new editor-snip% (editor seditor))])
+        (p seditor)
+        (let [(canvas (get-canvas))]
+          (when (and (is-a? canvas canvas:wide-snip<%>) wide?)
+            (send canvas add-wide-snip snip)))
+        (insert snip)
+        (send seditor lock #t)))
+
+    ))
+
+(define ext:text%
+  (text:wide-snip-mixin
+   (ext:text-mixin
+    text:hide-caret/selection%)))
+
+(define style:no-change (make-object style-delta% 'change-nothing))
+(define style:normal (make-object style-delta% 'change-normal))
+(define style:large (make-object style-delta% 'change-nothing))
+(void (send style:large set-size-mult 1.5))
+
+(define style:blue (make-object style-delta% 'change-nothing))
+(void (send style:blue set-delta-foreground "Blue"))
+
+(define style:red (make-object style-delta% 'change-nothing))
+(void (send style:red set-delta-foreground "Red"))
+
+(define style:green (make-object style-delta% 'change-nothing))
+(void (send style:green set-delta-foreground "ForestGreen"))
+
+(define style:purple (make-object style-delta% 'change-nothing))
+(void (send style:purple set-delta-foreground "Purple"))
+
+(define style:gray (make-object style-delta% 'change-nothing))
+(void (send style:gray set-delta-foreground "DimGray"))
+
+(define style:darkblue (make-object style-delta% 'change-nothing))
+(void (send style:darkblue set-delta-foreground "DarkBlue"))
+
+(define style:clickback (make-object style-delta% 'change-underline #t))
+(void (send style:clickback set-delta-foreground "blue"))
+
+(define style:bold (make-object style-delta% 'change-nothing))
+(void (send style:bold set-delta 'change-weight 'bold))
+
+(define style:italic (make-object style-delta% 'change-nothing))
+(void (send style:italic set-delta 'change-style 'italic))
+
+(define basic-styles
+  `([no-change . ,style:no-change]
+    [normal    . ,style:normal]
+    [large     . ,style:large]
+    [clickback . ,style:clickback]
+    [red       . ,style:red]
+    [blue      . ,style:blue]
+    [green     . ,style:green]
+    [purple    . ,style:purple]
+    [darkblue  . ,style:darkblue]
+    [bold      . ,style:bold]
+    [italic    . ,style:italic]
+    [error     . ,style:red]
+    [value     . ,style:darkblue]))
+
+(define schemeunit-styles
+  `([test-unexecuted . ,style:gray]
+    [test-success    . ,style:green]
+    [test-failure    . ,style:red]
+    [test-error      . ,style:red]
+    
+    [exn-type        . ,style:darkblue]
+    [exn-message     . ,style:red]
+    [exn-value       . ,style:darkblue]
+    [fail-type       . ,style:darkblue]))
+
+
+;; -- style-map classes
+
+(define extended-style-map%
+  (class* object% (style-map<%>)
+    (init-field styles
+                base)
+    (define/public (get-style sym)
+      (cond [(assq sym styles) => cdr]
+            [else (send base get-style sym)]))
+    (super-new)))
+
+(define empty-style-map%
+  (class* object% (style-map<%>)
+    (define/public (get-style sym)
+      (error 'get-style "unknown style: ~s" sym))
+    (super-new)))
+
+;; extend-style-map : style-map<%> styles -> style-map<%>
+(define (extend-style-map base styles)
+  (new extended-style-map% (base base) (styles styles)))
+
+;; empty-style-map : style-map<%>
+(define empty-style-map
+  (new empty-style-map%))
+
+;; basic-style-map : style-map<%>
+(define basic-style-map
+  (extend-style-map empty-style-map
+                    basic-styles))
+
+;; schemeunit-style-map : style-map<%>
+(define schemeunit-style-map
+  (extend-style-map basic-style-map 
+                    schemeunit-styles))

collects/schemeunit/private/gui/view.ss

@@ -0,0 +1,306 @@
+#lang scheme/base
+(require scheme/class
+         unstable/class-iop
+         scheme/list
+         scheme/gui
+         framework
+         mrlib/hierlist
+         "interfaces.ss"
+         "config.ss"
+         "model2rml.ss"
+         "rml.ss")
+
+(provide make-view-frame
+         view%)
+
+(define style-map schemeunit-style-map)
+
+#|
+
+To avoid getting sequence contract violations from editors, all editor
+mutations should be done in the eventspace thread.
+
+Can an update to a result<%> occur before its view link has been
+created? Answer = yes, quite easily it seems (I tried it.)
+
+See 'do-model-update': we yield if the view-link hasn't been created
+yet, since there should be a callback queued waiting to create it.
+
+With the 'queue-callback' calls and the one 'yield' call in place, I'm
+no longer able to trigger the race condition.
+
+----
+
+FIXME:
+
+Another problem: If tests are still running and a gui element "goes
+away", then get errors. Eg, run (test/gui success-and-failure-tests)
+and then immediately close the window.
+
+Why are these things actually disappearing, though? Shouldn't they
+still be there, just not visible?
+
+|#
+
+
+;; View
+(define view%
+  (class* object% (view<%>)
+    (init-field parent
+                controller)
+    (super-new)
+
+    (define editor (new ext:text% (style-map schemeunit-style-map)))
+    (define renderer
+      (new model-renderer%
+           (controller controller)
+           (editor editor)))
+
+    (define eventspace
+      (send (send parent get-top-level-window) get-eventspace))
+
+    (define -hpane (new panel:horizontal-dragable% (parent parent)))
+    (define -lpane (new vertical-pane% (parent -hpane)))
+    (define -rpane (new vertical-pane% (parent -hpane)))
+    (define -details-canvas 
+      (new canvas:wide-snip% (parent -rpane) (editor editor)))
+
+    (define tree-view
+      (new model-tree-view%
+           (parent -lpane) ;; tree-panel
+           (view this)
+           (controller controller)))
+
+    (send editor lock #t)
+    (with-handlers ([exn:fail? void])
+      (send -hpane set-percentages VIEW-PANE-PERCENTS))
+
+    ;; View Links
+
+    (define/public (create-view-link model parent)
+      (parameterize ((current-eventspace eventspace))
+        (queue-callback
+         (lambda ()
+           (send tree-view create-view-link model parent)))))
+
+    (define/private (get-view-link model)
+      (send tree-view get-view-link model))
+
+    ;; Methods
+
+    (define/private (get-selected-model)
+      (send/i controller controller<%> get-selected-model))
+
+    (send/i controller controller<%> listen-selected-model
+            (lambda (model)
+              (parameterize ((current-eventspace eventspace))
+                (queue-callback
+                 (lambda ()
+                   (let ([view-link (get-view-link model)])
+                     (send view-link select #t))
+                   (show-model model))))))
+
+    ;; Update Management
+
+    (define update-queue (make-hasheq))
+    (define update-lock (make-semaphore 1))
+
+    ;; queue-for-update : model -> void
+    (define/public (queue-for-update model)
+      (semaphore-wait update-lock)
+      (hash-set! update-queue model #t)
+      (semaphore-post update-lock)
+      (process-updates))
+
+    ;; process-updates : -> void
+    (define/private (process-updates)
+      (parameterize ((current-eventspace eventspace))
+        (queue-callback
+         (lambda ()
+           (let ([models-to-update (grab+clear-update-queue)])
+             (for ([model models-to-update])
+               (do-model-update model)))))))
+
+    ;; grab+clear-update-queue : -> void
+    ;; ** Must be called from eventspace thread.
+    (define/private (grab+clear-update-queue)
+      (semaphore-wait update-lock)
+      (if (positive? (hash-count update-queue))
+          (let ([old-queue update-queue])
+            (set! update-queue (make-hasheq))
+            (semaphore-post update-lock)
+            (reverse
+             (hash-map old-queue (lambda (k v) k))))
+          (begin (semaphore-post update-lock)
+                 null)))
+
+    ;; do-model-update : model<%> -> void
+    ;; ** Must be called from eventspace thread.
+    (define/private (do-model-update model)
+      (let ([view-link (get-view-link model)])
+        (cond [view-link
+               (send tree-view update-item view-link)
+               (when (eq? model (get-selected-model))
+                 (show-model model))]
+              [(not view-link)
+               ;; If the view-link has not been created,
+               ;; yield until it is.
+               (unless (yield)
+                 (error 'schemeunit-gui
+                        "internal error: no progress waiting for view-link"))
+               (do-model-update model)])))
+
+    ;; Update display
+
+    ;; show-model : result<%> -> void
+    ;; Displays the result in the Details area.
+    ;; ** Must be called from eventspace thread.
+    (define/private (show-model model)
+      (send* editor
+        (begin-edit-sequence)
+        (lock #f)
+        (erase))
+      (send renderer render-model/long model)
+      (send* editor
+        (lock #t)
+        (end-edit-sequence)
+        (scroll-to-position 0)))
+
+    ))
+
+
+;; tree-view% <: hierarchical-list%
+(define model-tree-view%
+  (class* hierarchical-list% ()
+    (init-field view
+                controller)
+    (super-new (style '(auto-hscroll)))
+
+    (inherit get-items)
+
+    ;; View Link
+
+    (define model=>view-link (make-hasheq))
+
+    (define/public (set-view-link model item)
+      (hash-set! model=>view-link model item))
+    (define/public (get-view-link model)
+      (hash-ref model=>view-link model #f))
+
+    ;; Behavior
+
+    (define/override (on-select item)
+      (let [(model (send item user-data))]
+        (send/i controller controller<%> set-selected-model model)))
+
+    (define/override (on-double-select item)
+      (when (is-a? item hierarchical-list-compound-item<%>)
+        (if (send item is-open?)
+            (send item close)
+            (send item open))))
+
+    (define/private (ensure-tree-visible model)
+      (let* [(parent (send model get-parent))
+             (parent-view-link (and parent (get-view-link parent)))]
+        (when (and parent (not (send parent-view-link is-open?)))
+          (ensure-tree-visible parent)
+          (send parent-view-link open))))
+
+    ;; Construction
+
+    ;; create-view-link : result<%> suite-result<%>/#f-> item
+    (define/public (create-view-link model parent)
+      (let ([parent-link
+             (if parent
+                 (get-view-link parent)
+                 this)])
+        (initialize-view-link (cond [(is-a? model suite<%>)
+                                     (send parent-link new-list)]
+                                    [(is-a? model case<%>)
+                                     (send parent-link new-item)])
+                              model)))
+
+    ;; initialize-view-link : result<%> (U compound-item% item%) -> item
+    (define/private (initialize-view-link item model)
+      (set-view-link model item)
+      (send item user-data model)
+      (insert-text (send item get-editor)
+                   (send model get-name)
+                   (send style-map get-style
+                         (if (is-a? model suite<%>)
+                             'bold
+                             'normal))))
+
+    ;; update-item : item% -> void
+    (define/public (update-item view-link)
+      (let* ([editor (send view-link get-editor)]
+             [model (send view-link user-data)]
+             [name (send/i model result<%> get-name)]
+             [style-name
+              (cond [(not (send/i model result<%> finished?)) 'test-unexecuted]
+                    [(send/i model result<%> success?) 'test-success]
+                    [(send/i model result<%> failure?) 'test-failure]
+                    [(send/i model result<%> error?) 'test-error])]
+             [style (send/i style-map style-map<%> get-style style-name)]
+             [output? (send/i model result<%> has-output?)]
+             [trash? (send/i model result<%> has-trash?)])
+        (send editor begin-edit-sequence #f)
+        (send editor delete (string-length name) (send editor last-position) #f)
+        (when (or output? trash?)
+          (send editor insert
+                (output-icon)
+                (string-length name)
+                'same
+                #f))
+        (send editor change-style style 0 (send editor last-position) #f)
+        (send editor end-edit-sequence)))))
+
+
+;; view-frame% <: frame%
+(define view-frame%
+  (class (frame:standard-menus-mixin 
+           (frame:basic-mixin frame%))
+
+    (init [width (pref:width)]
+          [height (pref:height)])
+    (super-new (width width) (height height))
+
+    (inherit get-help-menu
+             get-width
+             get-height)
+
+    (define-syntax override-false
+      (syntax-rules ()
+        [(override-false name ...)
+         (begin (define/override (name . _) #f) ...)]))
+
+    (override-false file-menu:create-new?
+                    file-menu:create-open?
+                    file-menu:create-open-recent?
+                    file-menu:create-revert?
+                    file-menu:create-save?
+                    file-menu:create-save-as?
+                    file-menu:create-print?
+                    edit-menu:create-undo?
+                    edit-menu:create-redo?
+                    edit-menu:create-cut?
+                    edit-menu:create-paste?
+                    edit-menu:create-clear?
+                    edit-menu:create-find?
+                    #;edit-menu:create-replace-and-find-again?
+                    edit-menu:create-preferences?)
+
+    (define/augment (on-close)
+      (pref:width (get-width))
+      (pref:height (get-height))
+      (inner (void) on-close))
+
+    (send (get-help-menu) delete)))
+
+;; make-view-frame : -> frame%
+(define (make-view-frame)
+  (let ([frame 
+         (new view-frame%
+              (label FRAME-LABEL))])
+    (send frame show #t)
+    frame))

collects/schemeunit/private/name-collector.ss

@@ -31,7 +31,7 @@
 (require "base.ss"
          "monad.ss"
          "hash-monad.ss"
-         (lib "list.ss" "srfi" "1"))
+         srfi/1)
 
 (provide display-test-case-name
          push-suite-name!

collects/schemeunit/private/result.ss

@@ -28,9 +28,8 @@
 
 #lang scheme/base
 
-(require
+(require "base.ss"
- (file "base.ss")
+         "test-suite.ss")
- (file "test-suite.ss"))
 
 (provide (all-defined-out))
 

collects/schemeunit/private/test-case.ss

@@ -1,18 +1,17 @@
 #lang scheme/base
 
-(require (for-syntax scheme/base))
+(require (for-syntax scheme/base)
-
+         "base.ss"
-(require (file "base.ss")
+         "format.ss"
-         (file "format.ss")
+         "check-info.ss"
-         (file "check-info.ss")
+         "check.ss")
-         (file "check.ss"))
 
 (provide current-test-name
          current-test-case-around
-         
+
          test-begin
          test-case
-         
+
          before
          after
          around)

collects/schemeunit/private/test-suite.ss

@@ -1,8 +1,7 @@
 #lang scheme/base
 
-(require (for-syntax scheme/base))
+(require (for-syntax scheme/base)
-
+         "base.ss"
-(require "base.ss"
          "test-case.ss"
          "check.ss")
 
@@ -11,9 +10,9 @@
          test-suite-check-around
          delay-test
          make-test-suite
-         
+
          apply-test-suite
-         
+
          define-test-suite
          define/provide-test-suite)
 
@@ -66,7 +65,7 @@
          [kid-seed (fdown suite name before after seed)]
          [kid-seed ((schemeunit-test-suite-tests suite) fdown fup fhere kid-seed)])
     (fup suite name before after seed kid-seed)))
-  
+
 ;; test-suite : name [#:before thunk] [#:after thunk] test ...
 ;;                     -> test-suite
 ;;
@@ -167,7 +166,7 @@
      (define name
        (test-suite (symbol->string (quote name))
                    test ...))]))
-  
+
 (define-syntax define/provide-test-suite
   (syntax-rules ()
     [(define/provide-test-suite name test ...)

collects/schemeunit/private/test.ss

@@ -1,15 +1,14 @@
 #lang scheme/base
 
-(require (for-syntax scheme/base))
+(require (for-syntax scheme/base)
-
+         "base.ss"
-(require "base.ss"
          "check.ss"
          "check-info.ss"
          "result.ss"
          "test-case.ss"
          "test-suite.ss"
          "util.ss")
-  
+
 (provide (struct-out exn:test:check)
          (struct-out check-info)
          (struct-out test-result)
@@ -18,7 +17,7 @@
          (struct-out test-success)
          (struct-out schemeunit-test-case)
          (struct-out schemeunit-test-suite)
-         
+
          with-check-info
          with-check-info*
 
@@ -50,13 +49,13 @@
          define-test-suite
          define/provide-test-suite
          test-suite*
-         
+
          before
          after
          around
 
          require/expose
-         
+
          define-shortcut
 
          test-check
@@ -70,18 +69,18 @@
          test-not-false
          test-exn
          test-not-exn
-         
+
          foldts
          fold-test-results
          run-test-case
          run-test
-         
+
          fail-check
 
          define-check
          define-simple-check
          define-binary-check
-         
+
          check
          check-exn
          check-not-exn

collects/schemeunit/private/util.ss

@@ -28,11 +28,9 @@
 
 #lang scheme/base
 
-(require (for-syntax scheme/base))
+(require (for-syntax scheme/base)
-
+         mzlib/etc
-(require mzlib/etc)
+         "check.ss"
-
-(require "check.ss"
          "test-suite.ss"
          "test-case.ss")
 

collects/schemeunit/run-tests.ss

@@ -1,10 +0,0 @@
-#lang scheme/base
-
-(require "all-schemeunit-tests.ss"
-         "main.ss"
-         "text-ui.ss")
-;         "graphical-ui.ss")
-
-;(run-tests all-schemeunit-tests)
-
-(run-tests success-and-failure-tests)

collects/schemeunit/scribblings/base.ss

@@ -5,12 +5,16 @@
  scribble/manual
 
  (for-label scheme/base
+            scheme/contract
             schemeunit
-            schemeunit/text-ui))
+            schemeunit/text-ui
+            schemeunit/gui))
 
 (provide
  (all-from-out scribble/eval
                scribble/manual)
  (for-label (all-from-out scheme/base
+                          scheme/contract
                           schemeunit
-                          schemeunit/text-ui)))
+                          schemeunit/text-ui
+                          schemeunit/gui)))

collects/schemeunit/scribblings/ui.scrbl

@@ -9,10 +9,12 @@ SchemeUnit provides a textual and a graphical user interface
 
 @defmodule[schemeunit/text-ui]
 
-The textual UI is in the @scheme[text-ui] module.  It is run
+The textual UI is in the @schememodname[schemeunit/text-ui] module.
-via the @scheme[run-tests] function
+It is run via the @scheme[run-tests] function.
 
-@defproc[(run-tests (test (or/c test-case? test-suite?)) (verbosity (symbols 'quite 'normal 'verbose) 'normal)) natural-number/c]{
+@defproc[(run-tests (test (or/c test-case? test-suite?))
+                    (verbosity (symbols 'quite 'normal 'verbose) 'normal))
+         natural-number/c]{
 
 The given @scheme[test] is run and the result of running it
 output to the @scheme[current-output-port].  The output is
@@ -29,7 +31,25 @@ information.
 @scheme[run-tests] returns the number of unsuccessful tests.}
 
 
-
 @section{Graphical User Interface}
 
-The GUI has not yet been updated to this version of SchemeUnit.
+@defmodule[schemeunit/gui]
+
+SchemeUnit also provides a GUI test runner, available from the
+@schememodname[schemeunit/gui] module.
+
+@defproc[(test/gui [test (or/c test-case? test-suite?)] ...)
+         any]{
+
+Creates a new SchemeUnit GUI window and runs each @scheme[test]. The
+GUI is updated as tests complete.
+
+}
+
+@defproc[(make-gui-runner)
+         (-> (or/c test-case? test-suite?) ... any)]{
+
+Creates a new SchemeUnit GUI window and returns a procedure that, when
+applied, runs the given tests and displays the results in the GUI.
+
+}

collects/schemeunit/text-ui.ss

@@ -31,19 +31,18 @@
 (require scheme/match
          scheme/pretty
          srfi/13
-         srfi/26)
+         srfi/26
-
+         "main.ss"
-(require "base.ss"
+         "private/base.ss"
-         "counter.ss"
+         "private/counter.ss"
-         "format.ss"
+         "private/format.ss"
-         "location.ss"
+         "private/location.ss"
-         "result.ss"
+         "private/result.ss"
-         "test.ss"
+         "private/check-info.ss"
-         "check-info.ss"
+         "private/monad.ss"
-         "monad.ss"
+         "private/hash-monad.ss"
-         "hash-monad.ss"
+         "private/name-collector.ss"
-         "name-collector.ss"
+         "private/text-ui-util.ss")
-         "text-ui-util.ss")
 
 (provide run-tests
          display-context

collects/schemeunit/tool.ss

@@ -0,0 +1,95 @@
+#lang scheme/base
+(require scheme/class
+         scheme/gui
+         framework
+         drscheme/tool
+         scheme/unit
+         (prefix-in drlink: "private/gui/drscheme-link.ss"))
+
+(provide tool@)
+
+;; CONSTANTS
+
+(define BACKTRACE-NO-MESSAGE "No message.")
+(define LINK-MODULE-SPEC 'schemeunit/private/gui/drscheme-link)
+
+(define-namespace-anchor drscheme-ns-anchor)
+
+;; ----
+
+;; close/eventspace : (a* -> b) -> (a* -> b)
+;; Returns a procedure that executes the procedure in the 
+;; eventspace current when close/eventspace was executed.
+;; Effectively, "close" the procedure in the current eventspace.
+(define (close-eventspace f)
+  (let ([es (current-eventspace)])
+    (lambda args
+      (parameterize [(current-eventspace es)]
+        (apply f args)))))
+
+(define (close-eventspace/async f)
+  (let ([es (current-eventspace)])
+    (lambda args
+      (parameterize ((current-eventspace es))
+        (queue-callback (lambda () (apply f args)))))))
+
+(define tool@
+  (unit
+    (import drscheme:tool^)
+    (export drscheme:tool-exports^)
+
+    ;; show-backtrace : exn -> void
+    (define show-backtrace
+      (close-eventspace/async
+       (lambda (msg bt)
+         (drscheme:debug:show-backtrace-window
+          (or msg BACKTRACE-NO-MESSAGE)
+          bt))))
+
+    (define (list->srcloc x)
+      (make-srcloc (list-ref x 0)
+                   (list-ref x 1)
+                   (list-ref x 2)
+                   (list-ref x 3)
+                   (list-ref x 4)))
+
+    (define (get-errortrace-backtrace exn)
+      exn)
+
+    ;; show-source : value number number -> void
+    (define show-source
+      (close-eventspace/async
+       (lambda (src pos span)
+         (drscheme:debug:open-and-highlight-in-file
+          (list (make-srcloc src #f #f pos span))))))
+
+    ;; Send them off to the drscheme-ui module.
+    ;; We'll still have to attach our instantiation of drscheme-link
+    ;; to the user namespace.
+    (set-box! drlink:link
+              (vector get-errortrace-backtrace
+                      show-backtrace
+                      show-source))
+
+    (define drscheme-ns (namespace-anchor->namespace drscheme-ns-anchor))
+
+    (define interactions-text-mixin
+      (mixin ((class->interface drscheme:rep:text%)) ()
+        (inherit get-user-namespace)
+        (super-new)
+
+        (define/private (setup-helper-module)
+          (namespace-attach-module drscheme-ns
+                                   LINK-MODULE-SPEC
+                                   (get-user-namespace)))
+
+        (define/override (reset-console)
+          (super reset-console)
+          (setup-helper-module))))
+
+    (drscheme:get/extend:extend-interactions-text interactions-text-mixin)
+
+    (define (phase1) (void))
+    (define (phase2) (void))
+
+    ))

collects/scribblings/gui/brush-list-class.scrbl

@@ -11,7 +11,7 @@ A global brush list, @scheme[the-brush-list], is created
  automatically.
 
 
-@defconstructor/make[()]{
+@defconstructor[()]{
 
 Creates an empty brush list.
 

collects/scribblings/gui/dc-path-class.scrbl

@@ -33,7 +33,7 @@ A path is not connected to any particular @scheme[dc<%>] object, so
  operations. Instead, a @scheme[dc<%>]'s origin and scale apply at the
  time that the path is drawn or used to set a region.
 
-@defconstructor/make[()]{
+@defconstructor[()]{
 
 Creates a new path that contains no sub-paths (and no @tech{open
 sub-path}).

collects/scribblings/gui/editor-admin-class.scrbl

@@ -18,7 +18,7 @@ To create a new @scheme[editor-admin%] class, all methods described
 
 
 
-@defconstructor/make[()]{
+@defconstructor[()]{
 
 Creates a (useless) editor administrator.
 

collects/scribblings/gui/editor-data-class.scrbl

@@ -8,7 +8,7 @@ snip or region in an editor. See also @|editordatadiscuss|.
 
 
 
-@defconstructor/make[()]{
+@defconstructor[()]{
 
 The element returned by @method[editor-data% get-next] is initialized
 to @scheme[#f].

collects/scribblings/gui/editor-wordbreak-map-class.scrbl

@@ -32,7 +32,7 @@ The presence of a flag in a character's value indicates that the
 
 
 
-@defconstructor/make[()]{
+@defconstructor[()]{
 
 All ASCII alpha-numeric characters are initialized with
  @scheme['(caret line selection)]. All other ASCII non-whitespace

collects/scribblings/gui/font-list-class.scrbl

@@ -9,7 +9,7 @@ A @scheme[font-list%] object maintains a list of @scheme[font%]
 A global font list, @scheme[the-font-list], is created automatically.
 
 
-@defconstructor/make[()]{
+@defconstructor[()]{
 
 Creates an empty font list.
 

collects/scribblings/gui/keymap-class.scrbl

@@ -25,7 +25,7 @@ A handler procedure in a keymap is invoked with a @scheme[key-event%]
  @scheme[editor<%>] object that received the keyboard or mouse event.
 
 
-@defconstructor/make[()]{
+@defconstructor[()]{
 
 Creates an empty keymap.
 

collects/scribblings/gui/mouse-event-class.scrbl

@@ -13,9 +13,9 @@ See also @|mousekeydiscuss|.
 
 
 
-@defconstructor[([event-type (one-of/c 'enter 'leave 'left-down 'left-up 
+@defconstructor[([event-type (or/c 'enter 'leave 'left-down 'left-up 
-                                       'middle-down 'middle-up 
+                                   'middle-down 'middle-up 
-                                       'right-down 'right-up 'motion)]
+                                   'right-down 'right-up 'motion)]
                  [left-down any/c #f]
                  [middle-down any/c #f]
                  [right-down any/c #f]
@@ -51,7 +51,7 @@ See the corresponding @schemeidfont{get-} and @schemeidfont{set-}
 
 }
 
-@defmethod[(button-changed? [button (one-of/c 'left 'middle 'right 'any) 'any])
+@defmethod[(button-changed? [button (or/c 'left 'middle 'right 'any) 'any])
            boolean?]{
 
 Returns @scheme[#t] if this was a mouse button press or release event,
@@ -64,7 +64,7 @@ If @scheme[button] is not @scheme['any], then @scheme[#t] is only returned
 
 }
 
-@defmethod[(button-down? [button (one-of/c 'left 'middle 'right 'any) 'any])
+@defmethod[(button-down? [button (or/c 'left 'middle 'right 'any) 'any])
            boolean?]{
 
 Returns @scheme[#t] if the event is for a button press, @scheme[#f]
@@ -75,7 +75,7 @@ If @scheme[button] is not @scheme['any], then @scheme[#t] is only returned
 
 }
 
-@defmethod[(button-up? [button (one-of/c 'left 'middle 'right 'any) 'any])
+@defmethod[(button-up? [button (or/c 'left 'middle 'right 'any) 'any])
            boolean?]{
 
 Returns @scheme[#t] if the event is for a button release, @scheme[#f]
@@ -142,9 +142,9 @@ Under Mac OS X, if a control-key press is combined with a mouse button
 }
 
 @defmethod[(get-event-type)
-           (one-of/c 'enter 'leave 'left-down 'left-up 
+           (or/c 'enter 'leave 'left-down 'left-up 
-                     'middle-down 'middle-up 
+                 'middle-down 'middle-up 
-                     'right-down 'right-up 'motion)]{
+                 'right-down 'right-up 'motion)]{
 
 Returns the type of the event; see @scheme[mouse-event%] for
 information about each event type. See also @method[mouse-event%
@@ -254,9 +254,9 @@ Under Mac OS X, if a control-key press is combined with a mouse button
 
 }
 
-@defmethod[(set-event-type [event-type (one-of/c 'enter 'leave 'left-down 'left-up 
+@defmethod[(set-event-type [event-type (or/c 'enter 'leave 'left-down 'left-up 
-                                                 'middle-down 'middle-up 
+                                             'middle-down 'middle-up 
-                                                 'right-down 'right-up 'motion)])
+                                             'right-down 'right-up 'motion)])
            void?]{
 
 Sets the type of the event; see @scheme[mouse-event%] for information

collects/scribblings/gui/pen-list-class.scrbl

@@ -13,7 +13,7 @@ A global pen list @indexed-scheme[the-pen-list] is created automatically.
 
 
 
-@defconstructor/make[()]{
+@defconstructor[()]{
 
 Creates an empty pen list.
 

collects/scribblings/gui/snip-admin-class.scrbl

@@ -20,7 +20,7 @@ Because a @scheme[snip-admin%] object typically owns more than one
 
 
 
-@defconstructor/make[()]{
+@defconstructor[()]{
 
 Creates a (useless) editor administrator.
 

collects/scribblings/gui/snip-class-class.scrbl

@@ -31,7 +31,7 @@ In deriving a new @scheme[snip-class%] class, override the
 See also @|snipclassdiscuss|.
 
 
-@defconstructor/make[()]{
+@defconstructor[()]{
 
 Creates a (useless) snip class.
 

collects/scribblings/gui/snip-class.scrbl

@@ -74,7 +74,7 @@ To define a class of snips that read specially with
 
 
 
-@defconstructor/make[()]{
+@defconstructor[()]{
 
 Creates a plain snip of length 1 with the @scheme["Basic"] style of
  @scheme[the-style-list].

collects/scribblings/gui/style-list-class.scrbl

@@ -15,7 +15,7 @@ See @|stylediscuss| for more information.
 
 
 
-@defconstructor/make[()]{
+@defconstructor[()]{
 
 The root style, named @scheme["Basic"], is automatically created.
 

collects/scribblings/gui/tab-snip-class.scrbl

@@ -7,7 +7,7 @@ An instance of @scheme[tab-snip%] is created automatically when a
  tab is inserted into an editor.
 
 
-@defconstructor/make[()]{
+@defconstructor[()]{
 
 Creates a snip for a single tab, though the tab is initially empty.
 

collects/scribblings/tools/unit.scrbl

@@ -574,7 +574,16 @@ Shows the interactions window
 Returns the currently active tab.
 
 }
-                                          
+
+@defmethod[(get-tab-filename [i (<=/c 0 (#,(method drscheme:unit:frame% get-tab-count)))]) string?]{
+  Returns a string naming the file in the @scheme[i]th tab or, if
+  the file is not saved, something like ``Untitled''.
+}
+
+@defmethod[(get-tab-count) exact-positive-integer?]{
+  Returns the number of open tabs in the frame.                                                    
+}
+
 @defmethod[(open-in-new-tab [filename (or/c path-string? #f)]) void?]{
   Opens a new tab in this frame. If @scheme[filename] is a @scheme[path-string?],
   It loads that file in the definitions window of the new tab.

collects/string-constants/english-string-constants.ss

@@ -730,6 +730,7 @@ please adhere to these guidelines:
  (most-recent-window "Most Recent Window")
   (next-tab "Next Tab")
   (prev-tab "Previous Tab")
+  (tab-i "Tab ~a: ~a") ;; menu item in the windows menu under mac os x. first ~a is filled with a number between 1 and 9; second one is the filename of the tab
 
  (view-menu-label "&View")
  (show-overview "Show &Program Contour") 

collects/tests/info.ss

@@ -21,6 +21,7 @@
     "plot"
     "profj"
     "r6rs"
+    "schemeunit"
     "srfi"
     "srpersist"
     "stepper"

collects/tests/schemeunit/all-schemeunit-tests.ss

@@ -1,6 +1,6 @@
 #lang scheme/base
 
-(require "main.ss"
+(require schemeunit
          "check-test.ss"
          "check-info-test.ss"
          "format-test.ss"
@@ -15,8 +15,7 @@
          "monad-test.ss"
          "hash-monad-test.ss"
          "counter-test.ss"
-         "text-ui-util-test.ss"
+         "text-ui-util-test.ss")
-         )
 
 (provide all-schemeunit-tests
          success-and-failure-tests)

collects/tests/schemeunit/base-test.ss

@@ -28,8 +28,8 @@
 
 #lang scheme/base
 
-(require "test.ss")
+(require schemeunit
-(require "base.ss")
+         schemeunit/private/base)
 
 (provide base-tests)
 

collects/tests/schemeunit/check-info-test.ss

@@ -27,8 +27,8 @@
 
 #lang scheme/base
 
-(require "test.ss"
+(require schemeunit
-         "check-info.ss")
+         schemeunit/private/check-info)
 
 (provide check-info-tests)
 

collects/tests/schemeunit/check-test.ss

@@ -28,13 +28,12 @@
 
 #lang scheme/base
 
-(require
+(require scheme/runtime-path
- scheme/runtime-path
+         srfi/1
- (lib "list.ss" "srfi" "1")
+         schemeunit
- (file "check.ss")
+         schemeunit/private/check
- (file "result.ss")
+         schemeunit/private/result
- (file "test.ss")
+         schemeunit/private/test-suite)
- (file "test-suite.ss"))
 
 (provide check-tests)
 
@@ -51,8 +50,6 @@
 (define-check (bad)
   (fail-check))
 
-(define-runtime-path check-file "check.ss")
-
 (define check-tests
   (test-suite
    "Check tests"
@@ -291,7 +288,7 @@
           (cns (current-namespace)))
       (parameterize ((current-namespace destns))
         (namespace-require '(for-syntax scheme/base))
-        (namespace-require `(file ,(path->string check-file)))
+        (namespace-require 'schemeunit/private/check)
         ;; First check that the right check macro got
         ;; used: ie that it didn't just compile the thing
         ;; as an application.
@@ -306,7 +303,7 @@
         ;; is writable
         (let ((stx-string "(check = 1 2)"))
           (write (compile (read-syntax
-                           check-file
+                           "check-test"
                            (open-input-string stx-string)))
                  (open-output-string))))))
    

collects/tests/schemeunit/counter-test.ss

@@ -27,11 +27,11 @@
 ;; Commentary:
 #lang scheme/base
 
-(require (lib "plt-match.ss")
+(require scheme/match
-         "test.ss")
+         schemeunit
-(require "counter.ss"
+         schemeunit/private/counter
-         "monad.ss"
+         schemeunit/private/monad
-         "hash-monad.ss")
+         schemeunit/private/hash-monad)
 
 (provide counter-tests)
 

collects/tests/schemeunit/format-test.ss

@@ -1,8 +1,8 @@
 #lang scheme/base
 
-(require (file "test.ss")
+(require schemeunit
-         (file "check-info.ss")
+         schemeunit/private/check-info
-         (file "format.ss"))
+         schemeunit/private/format)
 
 (provide format-tests)
 

collects/tests/schemeunit/hash-monad-test.ss

@@ -28,9 +28,9 @@
 
 #lang scheme/base
 
-(require "test.ss")
+(require schemeunit
-(require "monad.ss"
+         schemeunit/private/monad
-         "hash-monad.ss")
+         schemeunit/private/hash-monad)
 
 (provide hash-monad-tests)
 

collects/tests/schemeunit/location-test.ss

@@ -27,8 +27,8 @@
 ;; Commentary:
 #lang scheme/base
 
-(require "test.ss"
+(require schemeunit
-         "location.ss")
+         schemeunit/private/location)
 
 (provide location-tests)
 

collects/tests/schemeunit/monad-test.ss

@@ -29,8 +29,8 @@
 
 #lang scheme/base
 
-(require "test.ss")
+(require schemeunit
-(require "monad.ss")
+         schemeunit/private/monad)
 
 (provide monad-tests)
 

collects/tests/schemeunit/result-test.ss

@@ -1,8 +1,7 @@
 #lang scheme/base
-  
+
-(require
+(require schemeunit
- (file "test.ss")
+         schemeunit/private/result)
- (file "result.ss"))
 
 (provide result-tests)
   

collects/tests/schemeunit/run-tests.ss

@@ -0,0 +1,9 @@
+#lang scheme/base
+
+(require schemeunit
+         schemeunit/text-ui
+         "all-schemeunit-tests.ss")
+
+;(run-tests all-schemeunit-tests)
+
+(run-tests success-and-failure-tests)

collects/tests/schemeunit/standalone-check-test.ss

@@ -31,7 +31,7 @@
 
 #lang scheme/base
 
-(require "check.ss")
+(require schemeunit/private/check)
 
 ;; This check should succeed
 (check = 1 1 0.0)

collects/tests/schemeunit/standalone-test-case-test.ss

@@ -4,8 +4,8 @@
 
 #lang scheme/base
 
-(require "check.ss"
+(require schemeunit/private/check
-         "test-case.ss")
+         schemeunit/private/test-case)
 
 ;; These tests should succeeds
 (test-begin (check-eq? 1 1))

collects/tests/schemeunit/test-case-test.ss

@@ -1,10 +1,10 @@
 #lang scheme/base
 
-(require "base.ss"
+(require schemeunit/private/base
-         "check.ss"
+         schemeunit/private/check
-         "test-case.ss"
+         schemeunit/private/test-case
-         "test-suite.ss"
+         schemeunit/private/test-suite
-         "result.ss")
+         schemeunit/private/result)
 
 (provide test-case-tests)
 

collects/tests/schemeunit/test-suite-test.ss

@@ -1,7 +1,7 @@
 #lang scheme/base
 
-(require "check.ss"
+(require schemeunit
-         "test.ss")
+         schemeunit/private/check)
 
 (define run? #f)
 
@@ -26,6 +26,9 @@
    (test-begin
     (check-true run?))
 
+   ;; Reset state so tests can be run again.
+   (set! run? #f)
+
    (test-case
     "define-test"
     (check-pred test-suite? define-test))

collects/tests/schemeunit/test-test.ss

@@ -1,15 +1,13 @@
 #lang scheme/base
 
-(require (for-syntax scheme/base))
+(require (for-syntax scheme/base)
-
+         scheme/runtime-path
-(require scheme/runtime-path
          srfi/1
-         srfi/13)
+         srfi/13
+         schemeunit
+         schemeunit/private/util
+         schemeunit/private/location)
 
-(require (file "test.ss")
-         (file "util.ss")
-         (file "location.ss"))
-  
 (provide test-tests)
 
 (define successful-suite
@@ -25,8 +23,6 @@
     "Example 3"
     #t)))
 
-(define-runtime-path test-file "test.ss")
-
 (define-check (check-test-results test successes failures errors)
   (let ((results (run-test test)))
     (check = (length results) (+ successes failures errors))
@@ -47,13 +43,13 @@
   (let ((destns (make-base-namespace))
         (cns (current-namespace)))
     (parameterize ((current-namespace destns))
-      (namespace-require `(file ,(path->string test-file)))
+      (namespace-require 'schemeunit)
       (check-exn (lambda (e)
                    (check-pred exn:fail:syntax? e)
                    (check string-contains (exn-message e) msg))
                  (lambda ()
                    (eval sexp))))))
-  
+
 (define test-tests
   (test-suite
    "Test tests"

collects/tests/schemeunit/text-ui-test.ss

@@ -30,10 +30,9 @@
 
 (require scheme/runtime-path
          srfi/1
-         srfi/13)
+         srfi/13
-
+         schemeunit
-(require "test.ss"
+         schemeunit/text-ui)
-         "text-ui.ss")
 
 (provide text-ui-tests)
 

collects/tests/schemeunit/text-ui-util-test.ss

@@ -27,8 +27,8 @@
 ;; Commentary:
 #lang scheme/base
 
-(require "test.ss")
+(require schemeunit
-(require "text-ui-util.ss")
+         schemeunit/private/text-ui-util)
 
 (provide text-ui-util-tests)
 

collects/tests/schemeunit/util-test.ss

@@ -1,8 +1,7 @@
 #lang scheme/base
 
-(require
+(require schemeunit
- (file "test.ss")
+         schemeunit/private/util)
- (file "util.ss"))
 
 (provide util-tests)
 

collects/tests/srfi/19/tests.ss

@@ -8,7 +8,7 @@
 
 (require srfi/19/time)
 
-(require schemeunit/test
+(require schemeunit
          schemeunit/text-ui)
 
 (define-check (check-comparisons comparison times expected)

collects/tests/xml/test-clark.ss

@@ -1,13 +1,12 @@
 #lang scheme
 (require schemeunit
-         schemeunit/base
+         schemeunit/private/check
-         schemeunit/test-case
+         schemeunit/private/test-case
-         schemeunit/check
+         schemeunit/private/test-suite
-         schemeunit/test-suite
          schemeunit/text-ui
          xml
          scheme/runtime-path)
-(require/expose schemeunit/test-suite
+(require/expose schemeunit/private/test-suite
                 (current-seed))
 
 (define (validate-xml? xml)