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

Syncing up.

Browse Source 
svn: r18249
This commit is contained in:
Stevie Strickland 2010-02-21 03:37:21 +00:00
commit 6f3b676fa5
77 changed files with 2021 additions and 228 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/drscheme/private/debug.ss
View File

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

13
collects/drscheme/private/main.ss
View File

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

15
collects/drscheme/private/unit.ss
View File

@ -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
defs
(if fn
(get-tab-label-from-filename fn)
(send defs get-filename/untitled-name))))))
(get-defs-tab-filename defs))))
(define/private (get-defs-tab-filename defs)
(let ([fn (send defs get-filename)])
(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

18
collects/schemeunit/gui.ss Normal file
View File

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

36
collects/schemeunit/info.ss
View File

@ -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 required-core-version "4.0.0.0")
(define categories '(devtools))
(define can-be-loaded-with 'all)
(define scribblings '(("scribblings/schemeunit.scrbl" (multi-page) (tool))))
(define tools '[("tool.ss")])
(define tool-names '["SchemeUnit DrScheme integration"])
(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))

6
collects/schemeunit/main.ss
View File

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

0
collects/schemeunit/base.ss → collects/schemeunit/private/base.ss
View File

0
collects/schemeunit/check-info.ss → collects/schemeunit/private/check-info.ss
View File

8
collects/schemeunit/check.ss → collects/schemeunit/private/check.ss
View File

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

7
collects/schemeunit/counter.ss → collects/schemeunit/private/counter.ss
View File

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

23
collects/schemeunit/format.ss → collects/schemeunit/private/format.ss
View File

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

48
collects/schemeunit/private/gui/cache-box.ss Normal file
View File

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

45
collects/schemeunit/private/gui/config.ss Normal file
View File

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

50
collects/schemeunit/private/gui/controller.ss Normal file
View File

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

17
collects/schemeunit/private/gui/drscheme-link.ss Normal file
View File

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

97
collects/schemeunit/private/gui/drscheme-ui.ss Normal file
View File

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

150
collects/schemeunit/private/gui/gui.ss Normal file
View File

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

111
collects/schemeunit/private/gui/gvector.ss Normal file
View File

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

63
collects/schemeunit/private/gui/interfaces.ss Normal file
View File

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

148
collects/schemeunit/private/gui/model.ss Normal file
View File

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

458
collects/schemeunit/private/gui/model2rml.ss Normal file
View File

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

BIN
collects/schemeunit/private/gui/output-icon.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 513 B

187
collects/schemeunit/private/gui/rml.ss Normal file
View File

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

306
collects/schemeunit/private/gui/view.ss Normal file
View File

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

0
collects/schemeunit/hash-monad.ss → collects/schemeunit/private/hash-monad.ss
View File

0
collects/schemeunit/location.ss → collects/schemeunit/private/location.ss
View File

0
collects/schemeunit/monad.ss → collects/schemeunit/private/monad.ss
View File

2
collects/schemeunit/name-collector.ss → collects/schemeunit/private/name-collector.ss
View File

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

5
collects/schemeunit/result.ss → collects/schemeunit/private/result.ss
View File

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

15
collects/schemeunit/test-case.ss → collects/schemeunit/private/test-case.ss
View File

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

13
collects/schemeunit/test-suite.ss → collects/schemeunit/private/test-suite.ss
View File

@ -1,8 +1,7 @@
#lang scheme/base
(require (for-syntax scheme/base))
(require "base.ss"
(require (for-syntax scheme/base)
"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 ...)

19
collects/schemeunit/test.ss → collects/schemeunit/private/test.ss
View File

@ -1,15 +1,14 @@
#lang scheme/base
(require (for-syntax scheme/base))
(require "base.ss"
(require (for-syntax scheme/base)
"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

0
collects/schemeunit/text-ui-util.ss → collects/schemeunit/private/text-ui-util.ss
View File

8
collects/schemeunit/util.ss → collects/schemeunit/private/util.ss
View File

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

10
collects/schemeunit/run-tests.ss
View File

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

8
collects/schemeunit/scribblings/base.ss
View File

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

30
collects/schemeunit/scribblings/ui.scrbl
View File

@ -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
via the @scheme[run-tests] function
The textual UI is in the @schememodname[schemeunit/text-ui] module.
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.
}

25
collects/schemeunit/text-ui.ss
View File

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

95
collects/schemeunit/tool.ss Normal file
View File

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

2
collects/scribblings/gui/brush-list-class.scrbl
View File

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

2
collects/scribblings/gui/dc-path-class.scrbl
View File

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

2
collects/scribblings/gui/editor-admin-class.scrbl
View File

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

2
collects/scribblings/gui/editor-data-class.scrbl
View File

@ -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].

2
collects/scribblings/gui/editor-wordbreak-map-class.scrbl
View File

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

2
collects/scribblings/gui/font-list-class.scrbl
View File

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

2
collects/scribblings/gui/keymap-class.scrbl
View File

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

24
collects/scribblings/gui/mouse-event-class.scrbl
View File

@ -13,9 +13,9 @@ See also @|mousekeydiscuss|.
@defconstructor[([event-type (one-of/c 'enter 'leave 'left-down 'left-up
'middle-down 'middle-up
'right-down 'right-up 'motion)]
@defconstructor[([event-type (or/c 'enter 'leave 'left-down 'left-up
'middle-down 'middle-up
'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
'middle-down 'middle-up
'right-down 'right-up 'motion)]{
(or/c 'enter 'leave 'left-down 'left-up
'middle-down 'middle-up
'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
'middle-down 'middle-up
'right-down 'right-up 'motion)])
@defmethod[(set-event-type [event-type (or/c 'enter 'leave 'left-down 'left-up
'middle-down 'middle-up
'right-down 'right-up 'motion)])
void?]{
Sets the type of the event; see @scheme[mouse-event%] for information

2
collects/scribblings/gui/pen-list-class.scrbl
View File

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

2
collects/scribblings/gui/snip-admin-class.scrbl
View File

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

2
collects/scribblings/gui/snip-class-class.scrbl
View File

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

2
collects/scribblings/gui/snip-class.scrbl
View File

@ -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].

2
collects/scribblings/gui/style-list-class.scrbl
View File

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

2
collects/scribblings/gui/tab-snip-class.scrbl
View File

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

11
collects/scribblings/tools/unit.scrbl
View File

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

1
collects/string-constants/english-string-constants.ss
View File

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

1
collects/tests/info.ss
View File

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

5
collects/schemeunit/all-schemeunit-tests.ss → collects/tests/schemeunit/all-schemeunit-tests.ss
View File

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

4
collects/schemeunit/base-test.ss → collects/tests/schemeunit/base-test.ss
View File

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

4
collects/schemeunit/check-info-test.ss → collects/tests/schemeunit/check-info-test.ss
View File

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

19
collects/schemeunit/check-test.ss → collects/tests/schemeunit/check-test.ss
View File

@ -28,13 +28,12 @@
#lang scheme/base
(require
scheme/runtime-path
(lib "list.ss" "srfi" "1")
(file "check.ss")
(file "result.ss")
(file "test.ss")
(file "test-suite.ss"))
(require scheme/runtime-path
srfi/1
schemeunit
schemeunit/private/check
schemeunit/private/result
schemeunit/private/test-suite)
(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))))))

10
collects/schemeunit/counter-test.ss → collects/tests/schemeunit/counter-test.ss
View File

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

6
collects/schemeunit/format-test.ss → collects/tests/schemeunit/format-test.ss
View File

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

6
collects/schemeunit/hash-monad-test.ss → collects/tests/schemeunit/hash-monad-test.ss
View File

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

4
collects/schemeunit/location-test.ss → collects/tests/schemeunit/location-test.ss
View File

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

4
collects/schemeunit/monad-test.ss → collects/tests/schemeunit/monad-test.ss
View File

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

7
collects/schemeunit/result-test.ss → collects/tests/schemeunit/result-test.ss
View File

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

9
collects/tests/schemeunit/run-tests.ss Normal file
View File

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

2
collects/schemeunit/standalone-check-test.ss → collects/tests/schemeunit/standalone-check-test.ss
View File

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

4
collects/schemeunit/standalone-test-case-test.ss → collects/tests/schemeunit/standalone-test-case-test.ss
View File

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

10
collects/schemeunit/test-case-test.ss → collects/tests/schemeunit/test-case-test.ss
View File

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

7
collects/schemeunit/test-suite-test.ss → collects/tests/schemeunit/test-suite-test.ss
View File

@ -1,7 +1,7 @@
#lang scheme/base
(require "check.ss"
"test.ss")
(require schemeunit
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))

20
collects/schemeunit/test-test.ss → collects/tests/schemeunit/test-test.ss
View File

@ -1,15 +1,13 @@
#lang scheme/base
(require (for-syntax scheme/base))
(require scheme/runtime-path
(require (for-syntax scheme/base)
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"

7
collects/schemeunit/text-ui-test.ss → collects/tests/schemeunit/text-ui-test.ss
View File

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

4
collects/schemeunit/text-ui-util-test.ss → collects/tests/schemeunit/text-ui-util-test.ss
View File

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

5
collects/schemeunit/util-test.ss → collects/tests/schemeunit/util-test.ss
View File

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

2
collects/tests/srfi/19/tests.ss
View File

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

9
collects/tests/xml/test-clark.ss
View File

@ -1,13 +1,12 @@
#lang scheme
(require schemeunit
schemeunit/base
schemeunit/test-case
schemeunit/check
schemeunit/test-suite
schemeunit/private/check
schemeunit/private/test-case
schemeunit/private/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)